[Pkg] The Trunk: Morphic-ul.862.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Apr 11 22:00:53 UTC 2015
Levente Uzonyi uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-ul.862.mcz
==================== Summary ====================
Name: Morphic-ul.862
Author: ul
Time: 11 April 2015, 11:18:04.478 pm
UUID: 4e58017b-cf0b-4dd5-be4c-4b0f936186e3
Ancestors: Morphic-mt.861
Decrease the chance for race conditions, when a WorldState object is shared by multiple UI processes in WorldState >> #interCyclePause:.
=============== Diff against Morphic-mt.861 ===============
Item was added:
+ (PackageInfo named: 'Morphic') preamble: 'TheWorldMainDockingBar setTimeStamp'!
Item was added:
+ SystemOrganization addCategory: #'Morphic-Balloon'!
+ SystemOrganization addCategory: #'Morphic-Basic'!
+ SystemOrganization addCategory: #'Morphic-Basic-NewCurve'!
+ SystemOrganization addCategory: #'Morphic-Borders'!
+ SystemOrganization addCategory: #'Morphic-Collections-Arrayed'!
+ SystemOrganization addCategory: #'Morphic-Demo'!
+ SystemOrganization addCategory: #'Morphic-Events'!
+ SystemOrganization addCategory: #'Morphic-Explorer'!
+ SystemOrganization addCategory: #'Morphic-Kernel'!
+ SystemOrganization addCategory: #'Morphic-Layouts'!
+ SystemOrganization addCategory: #'Morphic-Menus'!
+ SystemOrganization addCategory: #'Morphic-Menus-DockingBar'!
+ SystemOrganization addCategory: #'Morphic-Models'!
+ SystemOrganization addCategory: #'Morphic-Pluggable Widgets'!
+ SystemOrganization addCategory: #'Morphic-Sound'!
+ SystemOrganization addCategory: #'Morphic-Sound-Synthesis'!
+ SystemOrganization addCategory: #'Morphic-Support'!
+ SystemOrganization addCategory: #'Morphic-Text Support'!
+ SystemOrganization addCategory: #'Morphic-TrueType'!
+ SystemOrganization addCategory: #'Morphic-Widgets'!
+ SystemOrganization addCategory: #'Morphic-Windows'!
+ SystemOrganization addCategory: #'Morphic-Worlds'!
Item was added:
+ BracketSliderMorph subclass: #AColorSelectorMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !AColorSelectorMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0!
+ ColorComponentSelector showing an alpha gradient over a hatched background.!
Item was added:
+ ----- Method: AColorSelectorMorph>>color: (in category 'accessing') -----
+ color: aColor
+ "Set the gradient colors."
+
+ super color: aColor asNontranslucentColor.
+ self fillStyle: self defaultFillStyle!
Item was added:
+ ----- Method: AColorSelectorMorph>>defaultFillStyle (in category 'as yet unclassified') -----
+ defaultFillStyle
+ "Answer the hue gradient."
+
+ ^(GradientFillStyle colors: {self color alpha: 0. self color})
+ origin: self topLeft;
+ direction: (self bounds isWide
+ ifTrue: [self width at 0]
+ ifFalse: [0 at self height])!
Item was added:
+ ----- Method: AColorSelectorMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Draw a hatch pattern first."
+ aCanvas
+ fillRectangle: self innerBounds
+ fillStyle: (InfiniteForm with: ColorPresenterMorph hatchForm).
+ super drawOn: aCanvas!
Item was added:
+ ----- Method: AColorSelectorMorph>>fillStyle: (in category 'visual properties') -----
+ fillStyle: fillStyle
+ "If it is a color then override with gradient."
+
+ fillStyle isColor
+ ifTrue: [self color: fillStyle]
+ ifFalse: [super fillStyle: fillStyle]!
Item was added:
+ ----- Method: AColorSelectorMorph>>initialize (in category 'initialization') -----
+ initialize
+ "Initialize the receiver."
+
+ super initialize.
+ self
+ value: 1.0;
+ color: Color black!
Item was added:
+ Model subclass: #AbstractHierarchicalList
+ instanceVariableNames: 'currentSelection myBrowser'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
+
+ !AbstractHierarchicalList commentStamp: '<historical>' prior: 0!
+ Contributed by Bob Arning as part of the ObjectExplorer package.
+ !
Item was added:
+ ----- Method: AbstractHierarchicalList>>genericMenu: (in category 'as yet unclassified') -----
+ genericMenu: aMenu
+
+ aMenu add: 'no menu yet' target: self selector: #yourself.
+ ^aMenu!
Item was added:
+ ----- Method: AbstractHierarchicalList>>getCurrentSelection (in category 'as yet unclassified') -----
+ getCurrentSelection
+
+ ^currentSelection!
Item was added:
+ ----- Method: AbstractHierarchicalList>>noteNewSelection: (in category 'as yet unclassified') -----
+ noteNewSelection: x
+
+ currentSelection := x.
+ self changed: #getCurrentSelection.
+ currentSelection ifNil: [^self].
+ currentSelection sendSettingMessageTo: self.
+ !
Item was added:
+ ----- Method: AbstractHierarchicalList>>perform:orSendTo: (in category 'as yet unclassified') -----
+ perform: selector orSendTo: otherTarget
+ "Selector was just chosen from a menu by a user. If can respond, then
+ perform it on myself. If not, send it to otherTarget, presumably the
+ editPane from which the menu was invoked."
+
+ (self respondsTo: selector)
+ ifTrue: [^ self perform: selector]
+ ifFalse: [^ otherTarget perform: selector]!
Item was added:
+ ----- Method: AbstractHierarchicalList>>update: (in category 'as yet unclassified') -----
+ update: aSymbol
+
+ aSymbol == #hierarchicalList ifTrue: [
+ ^self changed: #getList
+ ].
+ super update: aSymbol!
Item was added:
+ Morph subclass: #AbstractResizerMorph
+ instanceVariableNames: 'dotColor handleColor lastMouse'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !AbstractResizerMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0!
+ I am the superclass of a hierarchy of morph specialized in allowing the user to resize or rearrange windows and panes.!
Item was added:
+ ----- Method: AbstractResizerMorph>>dotColor (in category 'as yet unclassified') -----
+ dotColor
+
+ ^ dotColor ifNil: [self setDefaultColors. dotColor]!
Item was added:
+ ----- Method: AbstractResizerMorph>>handleColor (in category 'as yet unclassified') -----
+ handleColor
+
+ ^ handleColor ifNil: [self setDefaultColors. handleColor]!
Item was added:
+ ----- Method: AbstractResizerMorph>>handlesMouseDown: (in category 'as yet unclassified') -----
+ handlesMouseDown: anEvent
+
+ ^ true!
Item was added:
+ ----- Method: AbstractResizerMorph>>handlesMouseOver: (in category 'as yet unclassified') -----
+ handlesMouseOver: anEvent
+
+ ^ true
+ !
Item was added:
+ ----- Method: AbstractResizerMorph>>initialize (in category 'as yet unclassified') -----
+ initialize
+
+ super initialize.
+ self color: Color transparent!
Item was added:
+ ----- Method: AbstractResizerMorph>>isCursorOverHandle (in category 'as yet unclassified') -----
+ isCursorOverHandle
+
+ ^ true!
Item was added:
+ ----- Method: AbstractResizerMorph>>mouseDown: (in category 'as yet unclassified') -----
+ mouseDown: anEvent
+
+ lastMouse := anEvent cursorPoint!
Item was added:
+ ----- Method: AbstractResizerMorph>>mouseEnter: (in category 'as yet unclassified') -----
+ mouseEnter: anEvent
+
+ self isCursorOverHandle ifTrue:
+ [self setInverseColors.
+ self changed.
+ anEvent hand showTemporaryCursor: self resizeCursor]!
Item was added:
+ ----- Method: AbstractResizerMorph>>mouseLeave: (in category 'as yet unclassified') -----
+ mouseLeave: anEvent
+
+ anEvent hand showTemporaryCursor: nil.
+ self setDefaultColors.
+ self changed!
Item was added:
+ ----- Method: AbstractResizerMorph>>resizeCursor (in category 'as yet unclassified') -----
+ resizeCursor
+
+ self subclassResponsibility!
Item was added:
+ ----- Method: AbstractResizerMorph>>setDefaultColors (in category 'as yet unclassified') -----
+ setDefaultColors
+
+ handleColor := Color lightGray lighter lighter.
+ dotColor := Color gray lighter!
Item was added:
+ ----- Method: AbstractResizerMorph>>setInverseColors (in category 'as yet unclassified') -----
+ setInverseColors
+
+ handleColor := Color lightGray.
+ dotColor := Color white!
Item was added:
+ ----- Method: AbstractSound class>>updateScorePlayers (in category '*Morphic-Sounds-sound library-file in/out') -----
+ updateScorePlayers
+ | soundsBeingEdited |
+ "Force all ScorePlayers to update their instrument list from the sound library. This may done after loading, unloading, or replacing a sound to make all ScorePlayers feel the change."
+
+ ScorePlayer allSubInstancesDo:
+ [:p | p pause].
+ SoundPlayer shutDown.
+ soundsBeingEdited := EnvelopeEditorMorph allSubInstances collect: [:ed | ed soundBeingEdited].
+ ScorePlayerMorph allSubInstancesDo:
+ [:p | p updateInstrumentsFromLibraryExcept: soundsBeingEdited].
+ !
Item was added:
+ PluggableTextMorph subclass: #AcceptableCleanTextMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
Item was added:
+ ----- Method: AcceptableCleanTextMorph>>accept (in category 'menu commands') -----
+ accept
+ "Overridden to allow accept of clean text"
+
+ | textToAccept ok |
+ textToAccept := textMorph asText.
+ ok := setTextSelector isNil or:
+ [setTextSelector numArgs = 2
+ ifTrue:
+ [model
+ perform: setTextSelector
+ with: textToAccept
+ with: self]
+ ifFalse: [model perform: setTextSelector with: textToAccept]].
+ ok
+ ifTrue:
+ [self setText: self getText.
+ self hasUnacceptedEdits: false]!
Item was added:
+ RectangleMorph subclass: #AlignmentMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25' prior: 0!
+ Used for layout.
+ Since all morphs now support layoutPolicy the main use of this class is no longer needed.
+ Kept around for compability.
+ Supports a few methods not found elsewhere that can be convenient, eg. newRow
+ !
Item was added:
+ ----- Method: AlignmentMorph class>>columnPrototype (in category 'instance creation') -----
+ columnPrototype
+ "Answer a prototypical column"
+
+ | sampleMorphs aColumn |
+ sampleMorphs := #(red yellow green) collect:
+ [:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself].
+ aColumn := self inAColumn: sampleMorphs.
+ aColumn setNameTo: 'Column'.
+ aColumn color: Color veryVeryLightGray.
+ aColumn cellInset: 4; layoutInset: 6.
+ aColumn enableDragNDrop.
+ aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!' translated.
+ ^ aColumn!
Item was added:
+ ----- Method: AlignmentMorph class>>defaultNameStemForInstances (in category 'scripting') -----
+ defaultNameStemForInstances
+ "The code just below, now commented out, resulted in every instance of every sublcass of AlignmentMorph being given a default name of the form 'Alignment1', rather than the desired 'MoviePlayer1', 'ScriptEditor2', etc."
+
+ "^ 'Alignment'"
+
+ ^ super defaultNameStemForInstances!
Item was added:
+ ----- Method: AlignmentMorph class>>inAColumn: (in category 'instance creation') -----
+ inAColumn: aCollectionOfMorphs
+ "Answer a columnar AlignmentMorph holding the given collection"
+
+ | col |
+ col := self newColumn
+ color: Color transparent;
+ vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
+ layoutInset: 1;
+ borderColor: Color black;
+ borderWidth: 1;
+ wrapCentering: #center;
+ cellPositioning: #topCenter.
+ aCollectionOfMorphs do: [:each | col addMorphBack: each].
+ ^ col!
Item was added:
+ ----- Method: AlignmentMorph class>>inARow: (in category 'instance creation') -----
+ inARow: aCollectionOfMorphs
+ "Answer a row-oriented AlignmentMorph holding the given collection"
+
+ | aRow |
+ aRow := self newRow
+ color: Color transparent;
+ vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
+ layoutInset: 1;
+ borderColor: Color black;
+ borderWidth: 1;
+ wrapCentering: #center;
+ cellPositioning: #topCenter.
+ aCollectionOfMorphs do: [ :each | aRow addMorphBack: each].
+ ^ aRow!
Item was added:
+ ----- Method: AlignmentMorph class>>newColumn (in category 'instance creation') -----
+ newColumn
+
+ ^ self new
+ listDirection: #topToBottom;
+ hResizing: #spaceFill;
+ extent: 1 at 1;
+ vResizing: #spaceFill
+ !
Item was added:
+ ----- Method: AlignmentMorph class>>newRow (in category 'instance creation') -----
+ newRow
+
+ ^ self new
+ listDirection: #leftToRight;
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ extent: 1 at 1;
+ borderWidth: 0
+ !
Item was added:
+ ----- Method: AlignmentMorph class>>newSpacer: (in category 'instance creation') -----
+ newSpacer: aColor
+ "Answer a space-filling instance of me of the given color."
+
+ ^ self new
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ layoutInset: 0;
+ borderWidth: 0;
+ extent: 1 at 1;
+ color: aColor.
+ !
Item was added:
+ ----- Method: AlignmentMorph class>>newVariableTransparentSpacer (in category 'instance creation') -----
+ newVariableTransparentSpacer
+ "Answer a space-filling instance of me of the given color."
+
+ ^ self new
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ layoutInset: 0;
+ borderWidth: 0;
+ extent: 1 at 1;
+ color: Color transparent
+ !
Item was added:
+ ----- Method: AlignmentMorph class>>rowPrototype (in category 'instance creation') -----
+ rowPrototype
+ "Answer a prototypical row"
+
+ | sampleMorphs aRow |
+ sampleMorphs := (1 to: (2 + 3 atRandom)) collect:
+ [:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg', integer asString); yourself].
+ aRow := self inARow: sampleMorphs.
+ aRow setNameTo: 'Row'.
+ aRow enableDragNDrop.
+ aRow cellInset: 6.
+ aRow layoutInset: 8.
+ aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!' translated.
+ aRow color: Color veryVeryLightGray.
+ ^ aRow
+
+ "AlignmentMorph rowPrototype openInHand"!
Item was added:
+ ----- Method: AlignmentMorph>>canHaveFillStyles (in category 'visual properties') -----
+ canHaveFillStyles
+ "Return true if the receiver can have general fill styles; not just colors.
+ This method is for gradually converting old morphs."
+
+ ^ self class == AlignmentMorph "no subclasses"!
Item was added:
+ ----- Method: AlignmentMorph>>convertOldAlignmentsNov2000:using: (in category 'object fileIn') -----
+ convertOldAlignmentsNov2000: varDict using: smartRefStrm
+ "major change - much of AlignmentMorph is now implemented more generally in Morph"
+
+ "These are going away
+ #('orientation' 'centering' 'hResizing' 'vResizing'
+ 'inset' 'minCellSize' 'layoutNeeded' 'priorFullBounds')"
+
+ | orientation centering hResizing vResizing inset minCellSize inAlignment |
+ orientation := varDict at: 'orientation'.
+ centering := varDict at: 'centering'.
+ hResizing := varDict at: 'hResizing'.
+ vResizing := varDict at: 'vResizing'.
+ inset := varDict at: 'inset'.
+ minCellSize := varDict at: 'minCellSize'.
+ (orientation == #horizontal or: [orientation == #vertical])
+ ifTrue: [self layoutPolicy: TableLayout new].
+ self cellPositioning: #topLeft.
+ self rubberBandCells: true.
+ orientation == #horizontal ifTrue: [self listDirection: #leftToRight].
+ orientation == #vertical ifTrue: [self listDirection: #topToBottom].
+ centering == #topLeft ifTrue: [self wrapCentering: #topLeft].
+ centering == #bottomRight ifTrue: [self wrapCentering: #bottomRight].
+ centering == #center
+ ifTrue:
+ [self wrapCentering: #center.
+ orientation == #horizontal
+ ifTrue: [self cellPositioning: #leftCenter]
+ ifFalse: [self cellPositioning: #topCenter]].
+ (inset isNumber or: [inset isPoint]) ifTrue: [self layoutInset: inset].
+ (minCellSize isNumber or: [minCellSize isPoint])
+ ifTrue: [self minCellSize: minCellSize].
+ (self hasProperty: #clipToOwnerWidth) ifTrue: [self clipSubmorphs: true].
+
+ "now figure out if our owner was an AlignmentMorph, even if it is reshaped..."
+ inAlignment := false.
+ owner isMorph
+ ifTrue: [(owner isAlignmentMorph) ifTrue: [inAlignment := true]]
+ ifFalse:
+ ["e.g., owner may be reshaped"
+
+ (owner class instanceVariablesString
+ findString: 'orientation centering hResizing vResizing') > 0
+ ifTrue:
+ ["this was an alignment morph being reshaped"
+
+ inAlignment := true]].
+ "And check for containment in system windows"
+ owner isSystemWindow ifTrue: [inAlignment := true].
+ (hResizing == #spaceFill and: [inAlignment not])
+ ifTrue: [self hResizing: #shrinkWrap]
+ ifFalse: [self hResizing: hResizing].
+ (vResizing == #spaceFill and: [inAlignment not])
+ ifTrue: [self vResizing: #shrinkWrap]
+ ifFalse: [self vResizing: vResizing]!
Item was added:
+ ----- Method: AlignmentMorph>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ | newish |
+ newish := super convertToCurrentVersion: varDict refStream:
+ smartRefStrm.
+
+ "major change - much of AlignmentMorph is now implemented
+ more generally in Morph"
+ varDict at: 'hResizing' ifPresent: [ :x |
+ ^ newish convertOldAlignmentsNov2000: varDict using:
+ smartRefStrm].
+ ^ newish
+ !
Item was added:
+ ----- Method: AlignmentMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 0!
Item was added:
+ ----- Method: AlignmentMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color
+ r: 0.8
+ g: 1.0
+ b: 0.8!
Item was added:
+ ----- Method: AlignmentMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self layoutPolicy: TableLayout new;
+ listDirection: #leftToRight;
+ wrapCentering: #topLeft;
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ layoutInset: 2;
+ rubberBandCells: true!
Item was added:
+ ----- Method: AlignmentMorph>>isAlignmentMorph (in category 'classification') -----
+ isAlignmentMorph
+
+ ^ true
+ !
Item was added:
+ ----- Method: AlignmentMorph>>openInWindowLabeled:inWorld: (in category 'initialization') -----
+ openInWindowLabeled: aString inWorld: aWorld
+
+ self layoutInset: 0.
+ ^super openInWindowLabeled: aString inWorld: aWorld.!
Item was added:
+ ----- Method: AlignmentMorph>>wantsKeyboardFocusFor: (in category 'event handling') -----
+ wantsKeyboardFocusFor: aSubmorph
+ aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true].
+ ^ super wantsKeyboardFocusFor: aSubmorph!
Item was added:
+ ColorMappingCanvas subclass: #AlphaBlendingCanvas
+ instanceVariableNames: 'alpha'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: AlphaBlendingCanvas>>alpha (in category 'accessing') -----
+ alpha
+ ^alpha!
Item was added:
+ ----- Method: AlphaBlendingCanvas>>alpha: (in category 'accessing') -----
+ alpha: newAlpha
+ alpha := newAlpha.!
Item was added:
+ ----- Method: AlphaBlendingCanvas>>image:at:sourceRect:rule: (in category 'private') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule
+ "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle."
+ rule = Form paint ifTrue:[
+ ^myCanvas
+ image: aForm
+ at: aPoint
+ sourceRect: sourceRect
+ rule: Form paintAlpha
+ alpha: alpha.
+ ].
+ rule = Form over ifTrue:[
+ ^myCanvas
+ image: aForm
+ at: aPoint
+ sourceRect: sourceRect
+ rule: Form blendAlpha
+ alpha: alpha.
+ ].!
Item was added:
+ ----- Method: AlphaBlendingCanvas>>mapColor: (in category 'private') -----
+ mapColor: aColor
+ aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..."
+ aColor isTransparent ifTrue:[^aColor].
+ aColor isOpaque ifTrue:[^aColor alpha: alpha].
+ ^aColor alpha: (aColor alpha * alpha)!
Item was added:
+ ----- Method: AlphaBlendingCanvas>>mapFillStyle: (in category 'private') -----
+ mapFillStyle: aFillStyle
+
+ ^ self alpha = 1.0
+ ifTrue: [aFillStyle]
+ ifFalse: [super mapFillStyle: aFillStyle]
+ !
Item was added:
+ ----- Method: AlphaBlendingCanvas>>on: (in category 'initialization') -----
+ on: aCanvas
+ myCanvas := aCanvas.
+ alpha := 1.0.!
Item was added:
+ PluggableListMorph subclass: #AlternatePluggableListMorphOfMany
+ instanceVariableNames: 'getSelectionListSelector setSelectionListSelector'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
+
+ !AlternatePluggableListMorphOfMany commentStamp: 'cmm 3/2/2010 14:39' prior: 0!
+ This is a multi-select list that is more conventional in its behavior than PluggableListMorphOfMany. It utilizes a shift+click mechanism for selecting ranges, and control+click for toggling individual selections. This list also allows fast mouse swipes without missing any message selections.!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany class>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:menu: (in category 'instance creation') -----
+ on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel
+ ^ self new
+ on: anObject
+ list: listSel
+ primarySelection: getSelectionSel
+ changePrimarySelection: setSelectionSel
+ listSelection: getListSel
+ changeListSelection: setListSel
+ menu: getMenuSel
+ keystroke: #arrowKey:from: "default"!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany class>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:menu:keystroke: (in category 'instance creation') -----
+ on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel
+ ^ self new
+ on: anObject
+ list: listSel
+ primarySelection: getSelectionSel
+ changePrimarySelection: setSelectionSel
+ listSelection: getListSel
+ changeListSelection: setListSel
+ menu: getMenuSel
+ keystroke: keyActionSel!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>changeModelSelection: (in category 'model access') -----
+ changeModelSelection: anInteger
+ "Change the model's selected item index to be anInteger."
+
+ ^self
+ changeModelSelection: anInteger
+ shifted: Sensor shiftPressed
+ controlled: Sensor controlKeyPressed
+ !
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>changeModelSelection:shifted:controlled: (in category 'model access') -----
+ changeModelSelection: anInteger shifted: shiftedBoolean controlled: controlledBoolean
+ "Change the model's selected item index to be anInteger."
+
+ setIndexSelector ifNotNil:
+ [ model
+ perform: setIndexSelector
+ with: anInteger
+ with: shiftedBoolean
+ with: controlledBoolean ]
+ !
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ ^ true!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>itemSelectedAmongMultiple: (in category 'model access') -----
+ itemSelectedAmongMultiple: index
+ ^self listSelectionAt: (self modelIndexFor: index)!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>list: (in category 'initialization') -----
+ list: listOfStrings
+ self isThisEverCalled .
+ scroller removeAllMorphs.
+ list := listOfStrings ifNil: [Array new].
+ list isEmpty ifTrue: [^ self selectedMorph: nil].
+ super list: listOfStrings.
+
+ "At this point first morph is sensitized, and all morphs share same handler."
+ scroller firstSubmorph on: #mouseEnterDragging
+ send: #mouseEnterDragging:onItem:
+ to: self.
+ scroller firstSubmorph on: #mouseUp
+ send: #mouseUp:onItem:
+ to: self.
+ "This should add this behavior to the shared event handler thus affecting all items"!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>listSelectionAt: (in category 'drawing') -----
+ listSelectionAt: index
+ getSelectionListSelector ifNil:[^false].
+ ^model perform: getSelectionListSelector with: index!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>listSelectionAt:put: (in category 'drawing') -----
+ listSelectionAt: index put: value
+ setSelectionListSelector ifNil:[^false].
+ ^model perform: setSelectionListSelector with: index with: value!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>mouseDown: (in category 'event handling') -----
+ mouseDown: event
+ | row |
+
+ event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed].
+
+ row := self rowAtLocation: event position.
+
+ row = 0 ifTrue: [^super mouseDown: event].
+
+ model okToChange ifFalse: [^ self]. "No change if model is locked"
+
+ "Inform model of selected item and let it toggle."
+ self
+ changeModelSelection: (self modelIndexFor: row)
+ shifted: event shiftPressed
+ controlled: event controlKeyPressed.
+
+
+ "
+ event hand releaseMouseFocus: aMorph.
+ submorphs do: [ :each | each changed ]
+ "!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>mouseMove: (in category 'event handling') -----
+ mouseMove: event
+ "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate"
+
+ | oldIndex oldVal row |
+ event position y < self top
+ ifTrue:
+ [scrollBar scrollUp: 1.
+ row := self rowAtLocation: scroller topLeft + (1 @ 1)]
+ ifFalse:
+ [row := event position y > self bottom
+ ifTrue:
+ [scrollBar scrollDown: 1.
+ self rowAtLocation: scroller bottomLeft + (1 @ -1)]
+ ifFalse: [ self rowAtLocation: event position]].
+ row = 0 ifTrue: [^super mouseDown: event].
+
+ model okToChange ifFalse: [^self]. "No change if model is locked"
+
+ "Set meaning for subsequent dragging of selection"
+ oldIndex := self getCurrentSelectionIndex.
+ oldIndex ~= 0 ifTrue: [oldVal := self listSelectionAt: oldIndex].
+ "Need to restore the old one, due to how model works, and set new one."
+ oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal].
+
+ "Inform model of selected item and let it toggle."
+ self
+ changeModelSelection: (self modelIndexFor: row)
+ shifted: true
+ controlled: event controlKeyPressed.
+ submorphs do: [:each | each changed]!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>mouseUp: (in category 'event handling') -----
+ mouseUp: event
+
+ event hand newKeyboardFocus: self.
+ hasFocus := true.!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:menu:keystroke: (in category 'initialization') -----
+ on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel
+ "setup a whole load of pluggability options"
+
+ getSelectionListSelector := getListSel.
+ setSelectionListSelector := setListSel.
+ self
+ on: anObject
+ list: listSel
+ selected: getSelectionSel
+ changeSelected: setSelectionSel
+ menu: getMenuSel
+ keystroke: keyActionSel!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>update: (in category 'event handling') -----
+ update: aSymbol
+ aSymbol == #allSelections ifTrue:
+ [self selectionIndex: self getCurrentSelectionIndex.
+ ^ self changed].
+ ^ super update: aSymbol!
Item was added:
+ FormCanvas subclass: #BalloonCanvas
+ instanceVariableNames: 'transform colorTransform engine aaLevel deferred'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Balloon'!
+
+ !BalloonCanvas commentStamp: '<historical>' prior: 0!
+ BalloonCanvas is a canvas using the BalloonEngine for drawing wherever possible. It has various methods which other canvases do not support due to the extra features of the balloon engine.!
Item was added:
+ ----- Method: BalloonCanvas>>aaLevel (in category 'accessing') -----
+ aaLevel
+ ^aaLevel!
Item was added:
+ ----- Method: BalloonCanvas>>aaLevel: (in category 'accessing') -----
+ aaLevel: newLevel
+ "Only allow changes to aaLevel if we're working on >= 8 bit forms"
+ form depth >= 8 ifFalse:[^self].
+ aaLevel = newLevel ifTrue:[^self].
+ self flush. "In case there are pending primitives in the engine"
+ aaLevel := newLevel.
+ engine ifNotNil:[engine aaLevel: aaLevel].!
Item was added:
+ ----- Method: BalloonCanvas>>asBalloonCanvas (in category 'converting') -----
+ asBalloonCanvas
+ ^self!
Item was added:
+ ----- Method: BalloonCanvas>>colorTransformBy: (in category 'transforming') -----
+ colorTransformBy: aColorTransform
+ aColorTransform ifNil:[^self].
+ colorTransform
+ ifNil:[colorTransform := aColorTransform]
+ ifNotNil:[colorTransform := colorTransform composedWithLocal: aColorTransform]!
Item was added:
+ ----- Method: BalloonCanvas>>copy (in category 'copying') -----
+ copy
+ self flush.
+ ^super copy resetEngine!
Item was added:
+ ----- Method: BalloonCanvas>>deferred (in category 'accessing') -----
+ deferred
+ ^deferred!
Item was added:
+ ----- Method: BalloonCanvas>>deferred: (in category 'accessing') -----
+ deferred: aBoolean
+ deferred == aBoolean ifTrue:[^self].
+ self flush. "Force pending prims on screen"
+ deferred := aBoolean.
+ engine ifNotNil:[engine deferred: aBoolean].!
Item was added:
+ ----- Method: BalloonCanvas>>drawBezier3Shape:color:borderWidth:borderColor: (in category 'balloon drawing') -----
+ drawBezier3Shape: vertices color: c borderWidth: borderWidth borderColor:
+ borderColor
+ self drawBezierShape: (Bezier3Segment convertBezier3ToBezier2:
+ vertices) color: c borderWidth: borderWidth borderColor: borderColor!
Item was added:
+ ----- Method: BalloonCanvas>>drawBezierShape:color:borderWidth:borderColor: (in category 'balloon drawing') -----
+ drawBezierShape: vertices color: c borderWidth: borderWidth borderColor: borderColor
+ "Draw a boundary shape that is defined by a list of vertices.
+ Each three subsequent vertices define a quadratic bezier segment.
+ For lines, the control point should be set to either the start or the end
+ of the bezier curve."
+ | fillC borderC |
+ fillC := self shadowColor ifNil:[c].
+ borderC := self shadowColor ifNil:[borderColor].
+ self ensuredEngine
+ drawBezierShape: vertices
+ fill: fillC
+ borderWidth: borderWidth
+ borderColor: borderC
+ transform: transform.!
Item was added:
+ ----- Method: BalloonCanvas>>drawCompressedShape: (in category 'balloon drawing') -----
+ drawCompressedShape: compressedShape
+ "Draw a compressed shape"
+ self ensuredEngine
+ drawCompressedShape: compressedShape
+ transform: transform.!
Item was added:
+ ----- Method: BalloonCanvas>>drawGeneralBezier3Shape:color:borderWidth:borderColor: (in category 'balloon drawing') -----
+ drawGeneralBezier3Shape: contours color: c borderWidth: borderWidth
+ borderColor: borderColor
+ | b2 |
+ b2 := contours collect: [:b3 | Bezier3Segment
+ convertBezier3ToBezier2: b3 ].
+ self drawGeneralBezierShape: b2 color: c borderWidth: borderWidth
+ borderColor: borderColor!
Item was added:
+ ----- Method: BalloonCanvas>>drawGeneralBezierShape:color:borderWidth:borderColor: (in category 'balloon drawing') -----
+ drawGeneralBezierShape: contours color: c borderWidth: borderWidth borderColor: borderColor
+ "Draw a general boundary shape (e.g., possibly containing holes)"
+ | fillC borderC |
+ fillC := self shadowColor ifNil:[c].
+ borderC := self shadowColor ifNil:[borderColor].
+ self ensuredEngine
+ drawGeneralBezierShape: contours
+ fill: fillC
+ borderWidth: borderWidth
+ borderColor: borderC
+ transform: transform.!
Item was added:
+ ----- Method: BalloonCanvas>>drawGeneralPolygon:color:borderWidth:borderColor: (in category 'balloon drawing') -----
+ drawGeneralPolygon: contours color: c borderWidth: borderWidth borderColor: borderColor
+ "Draw a general polygon (e.g., a polygon that can contain holes)"
+ | fillC borderC |
+ fillC := self shadowColor ifNil:[c].
+ borderC := self shadowColor ifNil:[borderColor].
+ self ensuredEngine
+ drawGeneralPolygon: contours
+ fill: fillC
+ borderWidth: borderWidth
+ borderColor: borderC
+ transform: transform.!
Item was added:
+ ----- Method: BalloonCanvas>>drawOval:color:borderWidth:borderColor: (in category 'balloon drawing') -----
+ drawOval: r color: c borderWidth: borderWidth borderColor: borderColor
+ "Draw the oval defined by the given rectangle"
+ | fillC borderC |
+ fillC := self shadowColor ifNil:[c].
+ borderC := self shadowColor ifNil:[borderColor].
+ self ensuredEngine
+ drawOval: r
+ fill: fillC
+ borderWidth: borderWidth
+ borderColor: borderC
+ transform: transform.!
Item was added:
+ ----- Method: BalloonCanvas>>drawPolygon:fillStyle: (in category 'drawing-polygons') -----
+ drawPolygon: vertices fillStyle: aFillStyle
+ "Fill the given polygon."
+ self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: nil!
Item was added:
+ ----- Method: BalloonCanvas>>drawPolygon:fillStyle:borderWidth:borderColor: (in category 'drawing-polygons') -----
+ drawPolygon: vertices fillStyle: aFillStyle borderWidth: borderWidth borderColor: borderColor
+ "Draw a simple polygon defined by the list of vertices."
+ | fillC borderC |
+ vertices ifEmpty: [ ^ self ].
+ fillC := self shadowColor ifNil:[aFillStyle].
+ borderC := self shadowColor ifNil:[borderColor].
+ self ensuredEngine
+ drawPolygon: (vertices copyWith: vertices first)
+ fill: fillC
+ borderWidth: borderWidth
+ borderColor: borderC
+ transform: transform.!
Item was added:
+ ----- Method: BalloonCanvas>>drawRectangle:color:borderWidth:borderColor: (in category 'balloon drawing') -----
+ drawRectangle: r color: c borderWidth: borderWidth borderColor: borderColor
+ "Draw a rectangle"
+ | fillC borderC |
+ fillC := self shadowColor ifNil:[c].
+ borderC := self shadowColor ifNil:[borderColor].
+ self ensuredEngine
+ drawRectangle: r
+ fill: fillC
+ borderWidth: borderWidth
+ borderColor: borderC
+ transform: transform.!
Item was added:
+ ----- Method: BalloonCanvas>>drawString:from:to:in:font:color: (in category 'TODO') -----
+ drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
+ (self ifNoTransformWithIn: boundsRect)
+ ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]!
Item was added:
+ ----- Method: BalloonCanvas>>ensuredEngine (in category 'accessing') -----
+ ensuredEngine
+ engine ifNil:[
+ engine := BalloonEngine new.
+ "engine := BalloonDebugEngine new"
+ engine aaLevel: aaLevel.
+ engine bitBlt: port.
+ engine destOffset: origin.
+ engine clipRect: clipRect.
+ engine deferred: deferred.
+ engine].
+ engine colorTransform: colorTransform.
+ engine edgeTransform: transform.
+ ^engine!
Item was added:
+ ----- Method: BalloonCanvas>>fillColor: (in category 'drawing') -----
+ fillColor: c
+ "Note: This always fills, even if the color is transparent."
+ "Note2: To achieve the above we must make sure that c is NOT transparent"
+ self frameAndFillRectangle: form boundingBox
+ fillColor: (c alpha: 1.0)
+ borderWidth: 0
+ borderColor: nil!
Item was added:
+ ----- Method: BalloonCanvas>>fillOval:color:borderWidth:borderColor: (in category 'drawing') -----
+ fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
+ "Draw a filled and outlined oval"
+ "Note: The optimization test below should actually read:
+ self ifNoTransformWithIn: (r insetBy: borderWidth // 2)
+ but since borderWidth is assumed to be very small related to r we don't check it."
+
+ (self ifNoTransformWithIn: r)
+ ifTrue:[^super fillOval: r color: c borderWidth: borderWidth borderColor: borderColor].
+
+ ^self drawOval: (r insetBy: borderWidth // 2)
+ color: c
+ borderWidth: borderWidth
+ borderColor: borderColor!
Item was added:
+ ----- Method: BalloonCanvas>>fillOval:fillStyle:borderWidth:borderColor: (in category 'drawing-ovals') -----
+ fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
+ "Fill the given rectangle."
+ ^self drawOval: (aRectangle insetBy: bw // 2)
+ color: aFillStyle "@@: Name confusion!!!!!!"
+ borderWidth: bw
+ borderColor: bc
+ !
Item was added:
+ ----- Method: BalloonCanvas>>fillRectangle:color: (in category 'drawing') -----
+ fillRectangle: r color: c
+ "Fill the rectangle with the given color"
+ ^self frameAndFillRectangle: r
+ fillColor: c
+ borderWidth: 0
+ borderColor: nil!
Item was added:
+ ----- Method: BalloonCanvas>>fillRectangle:fillStyle: (in category 'drawing-rectangles') -----
+ fillRectangle: aRectangle fillStyle: aFillStyle
+ "Fill the given rectangle."
+ ^self drawRectangle: aRectangle
+ color: aFillStyle "@@: Name confusion!!!!!!"
+ borderWidth: 0
+ borderColor: nil
+ !
Item was added:
+ ----- Method: BalloonCanvas>>fillRoundRect:radius:fillStyle: (in category 'drawing-rectangles') -----
+ fillRoundRect: aRectangle radius: radius fillStyle: fillStyle
+ | points |
+ radius asPoint <= (0 at 0)
+ ifTrue:[^self fillRectangle: aRectangle fillStyle: fillStyle].
+ (radius * 2) asPoint >= aRectangle extent
+ ifTrue:[^self fillOval: aRectangle fillStyle: fillStyle].
+ "decompose aRectangle into bezier form"
+ points := self makeRoundRectShape: aRectangle radius: radius.
+ "blast the bezier shape out"
+ self
+ drawBezierShape: points
+ color: fillStyle
+ borderWidth: 0
+ borderColor: nil.
+ !
Item was added:
+ ----- Method: BalloonCanvas>>flush (in category 'initialize') -----
+ flush
+ "Force all pending primitives onscreen"
+ engine ifNotNil:[engine flush].!
Item was added:
+ ----- Method: BalloonCanvas>>frameAndFillRectangle:fillColor:borderWidth:borderColor: (in category 'drawing') -----
+ frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor
+ "Draw a filled and outlined rectangle"
+ "Note: The optimization test below should actually read:
+ self ifNoTransformWithIn: (r insetBy: borderWidth // 2)
+ but since borderWidth is assumed to be very small related to r we don't check it."
+
+ (self ifNoTransformWithIn: r)
+ ifTrue:[^super frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor].
+
+ ^self drawRectangle: (r insetBy: borderWidth // 2)
+ color: c
+ borderWidth: borderWidth
+ borderColor: borderColor!
Item was added:
+ ----- Method: BalloonCanvas>>frameAndFillRectangle:fillColor:borderWidth:topLeftColor:bottomRightColor: (in category 'drawing') -----
+ frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
+ "Draw a beveled or raised rectangle"
+ | bw |
+
+ "Note: The optimization test below should actually read:
+ self ifNoTransformWithIn: (r insetBy: borderWidth // 2)
+ but since borderWidth is assumed to be very small related to r we don't check it."
+
+ (self ifNoTransformWithIn: r)
+ ifTrue:[^super frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor].
+
+ "Fill rectangle and draw top and left border"
+ bw := borderWidth // 2.
+ self drawRectangle: (r insetBy: bw)
+ color: fillColor
+ borderWidth: borderWidth
+ borderColor: topLeftColor.
+ "Now draw bottom right border."
+ self drawPolygon: (Array with: r topRight + (bw negated at bw)
+ with: r bottomRight - bw asPoint
+ with: r bottomLeft + (bw at bw negated))
+ color: nil
+ borderWidth: borderWidth
+ borderColor: bottomRightColor.!
Item was added:
+ ----- Method: BalloonCanvas>>frameRectangle:width:color: (in category 'drawing') -----
+ frameRectangle: r width: w color: c
+ "Draw a frame around the given rectangle"
+ ^self frameAndFillRectangle: r
+ fillColor: Color transparent
+ borderWidth: w
+ borderColor: c!
Item was added:
+ ----- Method: BalloonCanvas>>frameRoundRect:radius:width:color: (in category 'drawing-rectangles') -----
+ frameRoundRect: aRectangle radius: radius width: borderWidth color: borderColor
+ | outerPoints innerRect innerRadius innerPoints |
+ (borderWidth isZero or:[borderColor isTransparent])
+ ifTrue:[^self].
+ radius asPoint <= (0 at 0)
+ ifTrue:[^self frameRectangle: aRectangle width: borderWidth color: borderColor].
+ (radius * 2) asPoint >= aRectangle extent
+ ifTrue:[^self frameOval: aRectangle width: borderWidth color: borderColor].
+ "decompose inner rectangle into bezier shape"
+ innerRect := aRectangle insetBy: borderWidth.
+ innerRect area <= 0
+ ifTrue:[^self fillRoundRect: aRectangle radius: radius fillStyle: borderColor].
+ innerRadius := (radius - borderWidth) asPoint.
+ innerPoints := self makeRoundRectShape: innerRect radius: innerRadius.
+ "decompose outer rectangle into bezier shape"
+ outerPoints := self makeRoundRectShape: aRectangle radius: radius.
+ self
+ drawGeneralBezierShape: (Array with: outerPoints with: innerPoints)
+ color: borderColor
+ borderWidth: 0
+ borderColor: nil.!
Item was added:
+ ----- Method: BalloonCanvas>>ifNoTransformWithIn: (in category 'private') -----
+ ifNoTransformWithIn: box
+ "Return true if the current transformation does not affect the given bounding box"
+ | delta |
+ transform ifNil: [^true].
+ delta := (transform localPointToGlobal: box origin) - box origin.
+ ^(transform localPointToGlobal: box corner) - box corner = delta!
Item was added:
+ ----- Method: BalloonCanvas>>image:at:sourceRect:rule: (in category 'private') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule
+ | warp dstRect srcQuad dstOffset center |
+ (self ifNoTransformWithIn: sourceRect) & false
+ ifTrue:[^super image: aForm at: aPoint sourceRect: sourceRect rule: rule].
+ dstRect := (transform localBoundsToGlobal: (aForm boundingBox translateBy: aPoint)).
+ dstOffset := 0 at 0. "dstRect origin."
+ "dstRect := 0 at 0 corner: dstRect extent."
+ center := 0 at 0."transform globalPointToLocal: dstRect origin."
+ srcQuad := transform globalPointsToLocal: (dstRect innerCorners).
+ srcQuad := srcQuad collect:[:pt| pt - aPoint].
+ warp := (WarpBlt toForm: form)
+ sourceForm: aForm;
+ cellSize: 2; "installs a new colormap if cellSize > 1"
+ combinationRule: Form over.
+ warp copyQuad: srcQuad toRect: (dstRect translateBy: dstOffset).
+
+ self frameRectangle: (aForm boundingBox translateBy: aPoint) color: Color green.
+
+ "... TODO ... create a bitmap fill style from the form and use it for a simple rectangle."!
Item was added:
+ ----- Method: BalloonCanvas>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ aaLevel := 1.
+ deferred := false.!
Item was added:
+ ----- Method: BalloonCanvas>>isBalloonCanvas (in category 'testing') -----
+ isBalloonCanvas
+ ^true!
Item was added:
+ ----- Method: BalloonCanvas>>isVisible: (in category 'testing') -----
+ isVisible: aRectangle
+ ^transform
+ ifNil:[super isVisible: aRectangle]
+ ifNotNil:[super isVisible: (transform localBoundsToGlobal: aRectangle)]!
Item was added:
+ ----- Method: BalloonCanvas>>line:to:brushForm: (in category 'TODO') -----
+ line: point1 to: point2 brushForm: brush
+ "Who's gonna use this?"
+ | pt1 pt2 |
+ self flush. "Sorry, but necessary..."
+ transform
+ ifNil:[pt1 := point1. pt2 := point2]
+ ifNotNil:[pt1 := transform localPointToGlobal: point1.
+ pt2 := transform localPointToGlobal: point2].
+ ^super line: pt1 to: pt2 brushForm: brush!
Item was added:
+ ----- Method: BalloonCanvas>>line:to:width:color: (in category 'drawing') -----
+ line: pt1 to: pt2 width: w color: c
+ "Draw a line from pt1 to: pt2"
+
+ (aaLevel = 1 and: [self ifNoTransformWithIn:(pt1 rect: pt2)])
+ ifTrue:[^super line: pt1 to: pt2 width: w color: c].
+ ^self drawPolygon: (Array with: pt1 with: pt2)
+ color: c
+ borderWidth: w
+ borderColor: c!
Item was added:
+ ----- Method: BalloonCanvas>>makeRoundRectShape:radius: (in category 'private') -----
+ makeRoundRectShape: aRectangle radius: radius
+ "decompose a rounded rectangle into bezier form"
+ | ovalDiameter rectExtent segments points endPoint seg idx offset rectOffset |
+ ovalDiameter := (radius * 2) asPoint min: aRectangle extent.
+ (ovalDiameter x <= 0 or: [ovalDiameter y <= 0]) ifTrue: [
+ "degenerates into rectangle - just hand back four lines"
+ | topLeft topRight bottomLeft bottomRight |
+ topLeft := aRectangle topLeft.
+ topRight := aRectangle topRight.
+ bottomLeft := aRectangle bottomLeft.
+ bottomRight := aRectangle bottomRight.
+
+ points := Array new: 4 * 3.
+ points at: 1 put: topLeft.
+ points at: 2 put: topLeft.
+ points at: 3 put: topRight.
+
+ points at: 4 put: topRight.
+ points at: 5 put: topRight.
+ points at: 6 put: bottomRight.
+
+ points at: 7 put: bottomRight.
+ points at: 8 put: bottomRight.
+ points at: 9 put: bottomLeft.
+
+ points at: 10 put: bottomLeft.
+ points at: 11 put: bottomLeft.
+ points at: 12 put: topLeft.
+ ^points
+ ].
+ rectExtent := aRectangle extent - ovalDiameter.
+ rectOffset := aRectangle origin.
+ segments := Bezier2Segment makeEllipseSegments: (0 @ 0 extent: ovalDiameter).
+ "patch up the segments to include lines connecting the oval parts.
+ we need: 8*3 points for the oval parts + 4*3 points for the connecting lines"
+ points := Array new: 12 * 3.
+ idx := 0.
+ "Tweaked offsets to clean up curves. MAD"
+ endPoint := segments last end + rectOffset + (0 @ -1).
+ 1 to: 8 by: 2 do: [:i |
+ i = 1 ifTrue: [offset := rectOffset + (rectExtent x @ 0) + (1 @ -1)]. "top, tr"
+ i = 3 ifTrue: [offset := rectOffset + rectExtent + (1 @ 1)]. "right, br"
+ i = 5 ifTrue: [offset := rectOffset + (0 @ rectExtent y) + (0 @ 1)]. "bottom, bl"
+ i = 7 ifTrue: [offset := rectOffset + (0 @ -1)]."left, tl"
+ seg := segments at: i.
+ "insert a line segment for the horizontal part of the round rect"
+ points at: (idx := idx + 1) put: endPoint.
+ points at: (idx := idx + 1) put: endPoint.
+ points at: (idx := idx + 1) put: seg start + offset.
+ "now the first half-arc"
+ points at: (idx := idx + 1) put: seg start + offset.
+ points at: (idx := idx + 1) put: seg via + offset.
+ points at: (idx := idx + 1) put: seg end + offset.
+ "the second half-arc"
+ seg := segments at: i + 1.
+ points at: (idx := idx + 1) put: seg start + offset.
+ points at: (idx := idx + 1) put: seg via + offset.
+ points at: (idx := idx + 1) put: seg end + offset.
+ endPoint := seg end + offset.
+ ].
+ ^points!
Item was added:
+ ----- Method: BalloonCanvas>>paragraph:bounds:color: (in category 'TODO') -----
+ paragraph: para bounds: bounds color: c
+ (self ifNoTransformWithIn: bounds)
+ ifTrue:[^super paragraph: para bounds: bounds color: c].!
Item was added:
+ ----- Method: BalloonCanvas>>point:color: (in category 'drawing') -----
+ point: pt color: c
+ "Is there any use for this?"
+ | myPt |
+ transform
+ ifNil:[myPt := pt]
+ ifNotNil:[myPt := transform localPointToGlobal: pt].
+ ^super point: myPt color: c!
Item was added:
+ ----- Method: BalloonCanvas>>preserveStateDuring: (in category 'transforming') -----
+ preserveStateDuring: aBlock
+ | state result |
+ state := BalloonState new.
+ state transform: transform.
+ state colorTransform: colorTransform.
+ state aaLevel: self aaLevel.
+ result := aBlock value: self.
+ transform := state transform.
+ colorTransform := state colorTransform.
+ self aaLevel: state aaLevel.
+ ^result!
Item was added:
+ ----- Method: BalloonCanvas>>resetEngine (in category 'initialize') -----
+ resetEngine
+ engine := nil.!
Item was added:
+ ----- Method: BalloonCanvas>>transformBy: (in category 'transforming') -----
+ transformBy: aTransform
+ aTransform ifNil:[^self].
+ transform
+ ifNil:[transform := aTransform]
+ ifNotNil:[transform := transform composedWithLocal: aTransform]!
Item was added:
+ ----- Method: BalloonCanvas>>transformBy:during: (in category 'transforming') -----
+ transformBy: aDisplayTransform during: aBlock
+ | myTransform result |
+ myTransform := transform.
+ self transformBy: aDisplayTransform.
+ result := aBlock value: self.
+ transform := myTransform.
+ ^result!
Item was added:
+ PolygonMorph subclass: #BalloonMorph
+ instanceVariableNames: 'target offsetFromTarget balloonOwner'
+ classVariableNames: 'BalloonColor BalloonFont'
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !BalloonMorph commentStamp: '<historical>' prior: 0!
+ A balloon with text used for the display of explanatory information.
+
+ Balloon help is integrated into Morphic as follows:
+ If a Morph has the property #balloonText, then it will respond to #showBalloon by adding a text balloon to the world, and to #deleteBalloon by removing the balloon.
+
+ Moreover, if mouseOverEnabled is true (see class msg), then the Hand will arrange to cause display of the balloon after the mouse has lingered over the morph for a while, and removal of the balloon when the mouse leaves the bounds of that morph. In any case, the Hand will attempt to remove any such balloons before handling mouseDown events, or displaying other balloons.
+
+ Balloons should not be duplicated with veryDeepCopy unless their target is also duplicated at the same time.!
Item was added:
+ ----- Method: BalloonMorph class>>balloonColor (in category 'utility') -----
+ balloonColor
+ ^ BalloonColor!
Item was added:
+ ----- Method: BalloonMorph class>>balloonFont (in category 'utility') -----
+ balloonFont
+ ^ BalloonFont!
Item was added:
+ ----- Method: BalloonMorph class>>chooseBalloonFont (in category 'utility') -----
+ chooseBalloonFont
+ "BalloonMorph chooseBalloonFont"
+
+ Preferences
+ chooseFontWithPrompt: 'Ballon Help font...' translated
+ andSendTo: self
+ withSelector: #setBalloonFontTo:
+ highlightSelector: #balloonFont!
Item was added:
+ ----- Method: BalloonMorph class>>getBestLocation:for:corner: (in category 'private') -----
+ getBestLocation: vertices for: morph corner: cornerName
+ "Try four rel locations of the balloon for greatest unclipped area. 12/99 sma"
+
+ | rect maxArea verts rectCorner morphPoint mbc a mp dir bestVerts result usableArea |
+ "wiz 1/8/2005 Choose rect independantly of vertice order or size. Would be nice it this took into account curveBounds but it does not."
+ rect := Rectangle encompassing: vertices.
+ maxArea := -1.
+ verts := vertices.
+ usableArea := (morph world ifNil: [self currentWorld]) viewBox.
+ 1 to: 4 do: [:i |
+ dir := #(vertical horizontal) atWrap: i.
+ verts := verts collect: [:p | p flipBy: dir centerAt: rect center].
+ rectCorner := #(bottomLeft bottomRight topRight topLeft) at: i.
+ morphPoint := #(topCenter topCenter bottomCenter bottomCenter) at: i.
+ a := ((rect
+ align: (rect perform: rectCorner)
+ with: (mbc := morph boundsForBalloon perform: morphPoint))
+ intersect: usableArea) area.
+ (a > maxArea or: [a = rect area and: [rectCorner = cornerName]]) ifTrue:
+ [maxArea := a.
+ bestVerts := verts.
+ mp := mbc]].
+ result := bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:".
+ ^ result!
Item was added:
+ ----- Method: BalloonMorph class>>getTextMorph:for: (in category 'private') -----
+ getTextMorph: aStringOrMorph for: balloonOwner
+ "Construct text morph."
+ | m text |
+ aStringOrMorph isMorph
+ ifTrue: [m := aStringOrMorph]
+ ifFalse: [BalloonFont
+ ifNil: [text := aStringOrMorph]
+ ifNotNil: [text := Text
+ string: aStringOrMorph
+ attribute: (TextFontReference toFont: balloonOwner balloonFont)].
+ m := (TextMorph new contents: text) centered].
+ m setToAdhereToEdge: #adjustedCenter.
+ ^ m!
Item was added:
+ ----- Method: BalloonMorph class>>getVertices: (in category 'private') -----
+ getVertices: bounds
+ "Construct vertices for a balloon up and to left of anchor"
+
+ | corners |
+ corners := bounds corners atAll: #(1 4 3 2).
+ ^ (Array
+ with: corners first + (0 - bounds width // 2 @ 0)
+ with: corners first + (0 - bounds width // 4 @ (bounds height // 2))) , corners!
Item was added:
+ ----- Method: BalloonMorph class>>setBalloonColorTo: (in category 'utility') -----
+ setBalloonColorTo: aColor
+ aColor ifNotNil: [BalloonColor := aColor]!
Item was added:
+ ----- Method: BalloonMorph class>>setBalloonFontTo: (in category 'utility') -----
+ setBalloonFontTo: aFont
+ aFont ifNotNil: [BalloonFont := aFont]!
Item was added:
+ ----- Method: BalloonMorph class>>string:for: (in category 'instance creation') -----
+ string: str for: morph
+ ^ self string: str for: morph corner: #bottomLeft!
Item was added:
+ ----- Method: BalloonMorph class>>string:for:corner: (in category 'instance creation') -----
+ string: str for: morph corner: cornerName
+ "Make up and return a balloon for morph. Find the quadrant that
+ clips the text the least, using cornerName as a tie-breaker. tk 9/12/97"
+ | tm vertices |
+ tm := self
+ getTextMorph: (str asString withNoLineLongerThan: Preferences maxBalloonHelpLineLength)
+ for: morph.
+ vertices := self getVertices: tm bounds.
+ vertices := self
+ getBestLocation: vertices
+ for: morph
+ corner: cornerName.
+ ^ self new color: morph balloonColor;
+ setVertices: vertices;
+ addMorph: tm;
+ setTarget: morph!
Item was added:
+ ----- Method: BalloonMorph>>adjustedCenter (in category 'menus') -----
+ adjustedCenter
+ "Return the center of the original textMorph box within the balloon."
+
+ ^ (self vertices last: 4) average rounded !
Item was added:
+ ----- Method: BalloonMorph>>balloonOwner (in category 'accessing') -----
+ balloonOwner
+ ^balloonOwner!
Item was added:
+ ----- Method: BalloonMorph>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ self defaultColor muchDarker"Color black"!
Item was added:
+ ----- Method: BalloonMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "0 is appropriate for balloons because they are transient and wispy, not a solid object deserving a border."
+ ^ 0!
Item was added:
+ ----- Method: BalloonMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ self class balloonColor!
Item was added:
+ ----- Method: BalloonMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self beSmoothCurve.
+
+ offsetFromTarget := 0 @ 0!
Item was added:
+ ----- Method: BalloonMorph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+
+ "helpful for insuring some morphs always appear in front of or behind others.
+ smaller numbers are in front"
+
+ ^5 "Balloons are very front-like things"!
Item was added:
+ ----- Method: BalloonMorph>>popUpAt:forHand: (in category 'initialization') -----
+ popUpAt: aPoint forHand: aHand
+
+ self popUpForHand: aHand.!
Item was added:
+ ----- Method: BalloonMorph>>popUpFor:hand: (in category 'initialization') -----
+ popUpFor: aMorph hand: aHand
+ "Pop up the receiver as balloon help for the given hand"
+ balloonOwner := aMorph.
+ self popUpForHand: aHand.!
Item was added:
+ ----- Method: BalloonMorph>>popUpForHand: (in category 'initialization') -----
+ popUpForHand: aHand
+ "Pop up the receiver as balloon help for the given hand"
+ | worldBounds |
+
+ self lock.
+ self fullBounds. "force layout"
+ self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber.
+ aHand world addMorphFront: self.
+ "So that if the translation below makes it overlap the receiver, it won't
+ interfere with the rootMorphsAt: logic and hence cause flashing. Without
+ this, flashing happens, believe me!!"
+ ((worldBounds := aHand world bounds) containsRect: self bounds) ifFalse:
+ [self bounds: (self bounds translatedToBeWithin: worldBounds)].
+ aHand balloonHelp: self.
+ !
Item was added:
+ ----- Method: BalloonMorph>>setTarget: (in category 'private') -----
+ setTarget: aMorph
+ (target := aMorph) ifNotNil: [offsetFromTarget := self position - target position]!
Item was added:
+ ----- Method: BalloonMorph>>step (in category 'stepping and presenter') -----
+ step
+ "Move with target."
+
+ target ifNotNil: [self position: target position + offsetFromTarget].
+ !
Item was added:
+ ----- Method: BalloonMorph>>stepTime (in category 'testing') -----
+ stepTime
+ ^ 0 "every cycle"!
Item was added:
+ ----- Method: BitBlt class>>asGrafPort (in category '*Morphic') -----
+ asGrafPort
+ "Return the GrafPort associated with the receiver"
+ ^GrafPort!
Item was added:
+ ----- Method: BitmapFillStyle>>addFillStyleMenuItems:hand:from: (in category '*Morphic-Balloon') -----
+ addFillStyleMenuItems: aMenu hand: aHand from: aMorph
+ "Add the items for changing the current fill style of the receiver"
+ aMenu add: 'choose new graphic' translated target: self selector: #chooseNewGraphicIn:event: argument: aMorph.
+ aMenu add: 'grab new graphic' translated target: self selector: #grabNewGraphicIn:event: argument: aMorph.
+ super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.!
Item was added:
+ ----- Method: BitmapFillStyle>>chooseNewGraphicIn:event: (in category '*Morphic-Balloon') -----
+ chooseNewGraphicIn: aMorph event: evt
+ "Used by any morph that can be represented by a graphic"
+ | aGraphicalMenu |
+ aGraphicalMenu := GraphicalMenu new
+ initializeFor: self
+ withForms: aMorph reasonableBitmapFillForms
+ coexist: true.
+ aGraphicalMenu selector: #newForm:forMorph:;
+ argument: aMorph.
+ evt hand attachMorph: aGraphicalMenu!
Item was added:
+ ----- Method: BitmapFillStyle>>grabNewGraphicIn:event: (in category '*Morphic-Balloon') -----
+ grabNewGraphicIn: aMorph event: evt
+ "Used by any morph that can be represented by a graphic"
+ | fill |
+ fill := Form fromUser.
+ fill boundingBox area = 0
+ ifTrue: [^ self].
+ self form: fill.
+ self direction: fill width @ 0.
+ self normal: 0 @ fill height.
+ aMorph changed!
Item was added:
+ ----- Method: BitmapFillStyle>>newForm:forMorph: (in category '*Morphic-Balloon') -----
+ newForm: aForm forMorph: aMorph
+ self form: aForm.
+ self direction: (aForm width @ 0).
+ self normal: (0 @ aForm height).
+ aMorph changed.!
Item was added:
+ CornerGripMorph subclass: #BorderGripMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: BorderGripMorph>>drawOn: (in category 'as yet unclassified') -----
+ drawOn: aCanvas
+
+ "aCanvas fillRectangle: self bounds color: Color red" "for debugging"
+ !
Item was added:
+ ----- Method: BorderGripMorph>>setDefaultColors (in category 'as yet unclassified') -----
+ setDefaultColors!
Item was added:
+ ----- Method: BorderGripMorph>>setInverseColors (in category 'as yet unclassified') -----
+ setInverseColors!
Item was added:
+ Object subclass: #BorderStyle
+ instanceVariableNames: ''
+ classVariableNames: 'Default'
+ poolDictionaries: ''
+ category: 'Morphic-Borders'!
+
+ !BorderStyle commentStamp: 'kfr 10/27/2003 10:19' prior: 0!
+ See BorderedMorph
+
+ BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.!
Item was added:
+ ----- Method: BorderStyle class>>borderStyleChoices (in category 'instance creation') -----
+ borderStyleChoices
+ "Answer the superset of all supported borderStyle symbols"
+
+ ^ #(simple inset raised complexAltFramed complexAltInset complexAltRaised complexFramed complexInset complexRaised)!
Item was added:
+ ----- Method: BorderStyle class>>borderStyleForSymbol: (in category 'instance creation') -----
+ borderStyleForSymbol: sym
+ "Answer a border style corresponding to the given symbol"
+
+ | aSymbol |
+ aSymbol := sym == #none ifTrue: [#simple] ifFalse: [sym].
+ ^ self perform: aSymbol
+ "
+ | aSymbol selector |
+ aSymbol := sym == #none ifTrue: [#simple] ifFalse: [sym].
+ selector := Vocabulary eToyVocabulary translationKeyFor: aSymbol.
+ selector isNil ifTrue: [selector := aSymbol].
+ ^ self perform: selector
+ "
+ !
Item was added:
+ ----- Method: BorderStyle class>>color:width: (in category 'instance creation') -----
+ color: aColor width: aNumber
+ ^self width: aNumber color: aColor!
Item was added:
+ ----- Method: BorderStyle class>>complexAltFramed (in category 'instance creation') -----
+ complexAltFramed
+ ^ComplexBorder style: #complexAltFramed!
Item was added:
+ ----- Method: BorderStyle class>>complexAltInset (in category 'instance creation') -----
+ complexAltInset
+ ^ComplexBorder style: #complexAltInset!
Item was added:
+ ----- Method: BorderStyle class>>complexAltRaised (in category 'instance creation') -----
+ complexAltRaised
+ ^ComplexBorder style: #complexAltRaised!
Item was added:
+ ----- Method: BorderStyle class>>complexFramed (in category 'instance creation') -----
+ complexFramed
+ ^ComplexBorder style: #complexFramed!
Item was added:
+ ----- Method: BorderStyle class>>complexInset (in category 'instance creation') -----
+ complexInset
+ ^ComplexBorder style: #complexInset!
Item was added:
+ ----- Method: BorderStyle class>>complexRaised (in category 'instance creation') -----
+ complexRaised
+ ^ComplexBorder style: #complexRaised!
Item was added:
+ ----- Method: BorderStyle class>>default (in category 'instance creation') -----
+ default
+ ^Default ifNil:[Default := self new]!
Item was added:
+ ----- Method: BorderStyle class>>inset (in category 'instance creation') -----
+ inset
+ ^InsetBorder new!
Item was added:
+ ----- Method: BorderStyle class>>raised (in category 'instance creation') -----
+ raised
+ ^RaisedBorder new!
Item was added:
+ ----- Method: BorderStyle class>>simple (in category 'instance creation') -----
+ simple
+ "Answer a simple border style"
+
+ ^ SimpleBorder new!
Item was added:
+ ----- Method: BorderStyle class>>thinGray (in category 'instance creation') -----
+ thinGray
+ ^ self width: 1 color: Color gray!
Item was added:
+ ----- Method: BorderStyle class>>width: (in category 'instance creation') -----
+ width: aNumber
+ ^self width: aNumber color: Color black!
Item was added:
+ ----- Method: BorderStyle class>>width:color: (in category 'instance creation') -----
+ width: aNumber color: aColor
+ ^SimpleBorder new color: aColor; width: aNumber; yourself!
Item was added:
+ ----- Method: BorderStyle>>= (in category 'comparing') -----
+ = aBorderStyle
+ ^self species = aBorderStyle species
+ and:[self style == aBorderStyle style
+ and:[self width = aBorderStyle width
+ and:[self color = aBorderStyle color]]].!
Item was added:
+ ----- Method: BorderStyle>>baseColor (in category 'accessing') -----
+ baseColor
+ ^Color transparent!
Item was added:
+ ----- Method: BorderStyle>>baseColor: (in category 'accessing') -----
+ baseColor: aColor
+ "Ignored"!
Item was added:
+ ----- Method: BorderStyle>>color (in category 'accessing') -----
+ color
+ ^Color transparent!
Item was added:
+ ----- Method: BorderStyle>>color: (in category 'accessing') -----
+ color: aColor
+ "Ignored"!
Item was added:
+ ----- Method: BorderStyle>>colorsAtCorners (in category 'accessing') -----
+ colorsAtCorners
+ ^Array new: 4 withAll: self color!
Item was added:
+ ----- Method: BorderStyle>>dotOfSize:forDirection: (in category 'accessing') -----
+ dotOfSize: diameter forDirection: aDirection
+ | form |
+ form := Form extent: diameter at diameter depth: Display depth.
+ form getCanvas fillOval: form boundingBox color: self color.
+ ^form!
Item was added:
+ ----- Method: BorderStyle>>drawLineFrom:to:on: (in category 'drawing') -----
+ drawLineFrom: startPoint to: stopPoint on: aCanvas
+ ^aCanvas line: startPoint to: stopPoint width: self width color: self color!
Item was added:
+ ----- Method: BorderStyle>>frameOval:on: (in category 'drawing') -----
+ frameOval: aRectangle on: aCanvas
+ "Frame the given rectangle on aCanvas"
+ aCanvas frameOval: aRectangle width: self width color: self color!
Item was added:
+ ----- Method: BorderStyle>>framePolygon:on: (in category 'drawing') -----
+ framePolygon: vertices on: aCanvas
+ "Frame the given rectangle on aCanvas"
+ self framePolyline: vertices on: aCanvas.
+ self drawLineFrom: vertices last to: vertices first on: aCanvas.!
Item was added:
+ ----- Method: BorderStyle>>framePolyline:on: (in category 'drawing') -----
+ framePolyline: vertices on: aCanvas
+ "Frame the given rectangle on aCanvas"
+
+ | prev next |
+ prev := vertices first.
+ 2 to: vertices size
+ do:
+ [:i |
+ next := vertices at: i.
+ self
+ drawLineFrom: prev
+ to: next
+ on: aCanvas.
+ prev := next]!
Item was added:
+ ----- Method: BorderStyle>>frameRectangle:on: (in category 'drawing') -----
+ frameRectangle: aRectangle on: aCanvas
+ "Frame the given rectangle on aCanvas"
+ aCanvas frameRectangle: aRectangle width: self width color: self color!
Item was added:
+ ----- Method: BorderStyle>>hash (in category 'comparing') -----
+ hash
+ "hash is implemented because #= is implemented"
+ ^self species hash bitXor: (self width hash bitXor: self color hash)!
Item was added:
+ ----- Method: BorderStyle>>isBorderStyle (in category 'testing') -----
+ isBorderStyle
+ ^true!
Item was added:
+ ----- Method: BorderStyle>>isComplex (in category 'testing') -----
+ isComplex
+ ^false!
Item was added:
+ ----- Method: BorderStyle>>releaseCachedState (in category 'initialize') -----
+ releaseCachedState
+ "Release any associated cached state"!
Item was added:
+ ----- Method: BorderStyle>>style (in category 'accessing') -----
+ style
+ ^#none!
Item was added:
+ ----- Method: BorderStyle>>trackColorFrom: (in category 'color tracking') -----
+ trackColorFrom: aMorph
+ "If necessary, update our color to reflect a change in aMorphs color"!
Item was added:
+ ----- Method: BorderStyle>>width (in category 'accessing') -----
+ width
+ ^0!
Item was added:
+ ----- Method: BorderStyle>>width: (in category 'accessing') -----
+ width: aNumber
+ "Ignored"!
Item was added:
+ ----- Method: BorderStyle>>widthForRounding (in category 'accessing') -----
+ widthForRounding
+ ^self width!
Item was added:
+ Morph subclass: #BorderedMorph
+ instanceVariableNames: 'borderWidth borderColor'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Kernel'!
+
+ !BorderedMorph commentStamp: 'kfr 10/27/2003 11:17' prior: 0!
+ BorderedMorph introduce borders to morph. Borders have the instanceVariables borderWidth and borderColor.
+
+ BorderedMorph new borderColor: Color red; borderWidth: 10; openInWorld.
+
+ BorderedMorph also have a varaity of border styles: simple, inset, raised, complexAltFramed, complexAltInset, complexAltRaised, complexFramed, complexInset, complexRaised.
+ These styles are set using the classes BorderStyle, SimpleBorder, RaisedBorder, InsetBorder and ComplexBorder.
+
+ BorderedMorph new borderStyle: (SimpleBorder width: 1 color: Color white); openInWorld.
+ BorderedMorph new borderStyle: (BorderStyle inset width: 2); openInWorld.
+
+
+ !
Item was added:
+ ----- Method: BorderedMorph>>acquireBorderWidth: (in category 'geometry') -----
+ acquireBorderWidth: aBorderWidth
+ "Gracefully acquire the new border width, keeping the interior area intact and not seeming to shift"
+
+ | delta |
+ (delta := aBorderWidth- self borderWidth) = 0 ifTrue: [^ self].
+ self bounds: ((self bounds origin - (delta @ delta)) corner: (self bounds corner + (delta @ delta))).
+ self borderWidth: aBorderWidth.
+ self layoutChanged!
Item was added:
+ ----- Method: BorderedMorph>>addBorderStyleMenuItems:hand: (in category 'menu') -----
+ addBorderStyleMenuItems: aMenu hand: aHandMorph
+ "Add border-style menu items"
+
+ | subMenu |
+ subMenu := MenuMorph new defaultTarget: self.
+ "subMenu addTitle: 'border' translated."
+ subMenu addStayUpItemSpecial.
+ subMenu addList:
+ {{'border color...' translated. #changeBorderColor:}.
+ {'border width...' translated. #changeBorderWidth:}}.
+ subMenu addLine.
+ BorderStyle borderStyleChoices do:
+ [:sym | (self borderStyleForSymbol: sym)
+ ifNotNil:
+ [subMenu add: sym translated target: self selector: #setBorderStyle: argument: sym]].
+ aMenu add: 'border style' translated subMenu: subMenu
+ !
Item was added:
+ ----- Method: BorderedMorph>>addCornerGrips (in category 'lookenhancements') -----
+ addCornerGrips
+ self
+ addMorphBack: (TopLeftGripMorph new target: self; position: self position).
+ self
+ addMorphBack: (TopRightGripMorph new target: self; position: self position).
+ self
+ addMorphBack: (BottomLeftGripMorph new target: self;position: self position).
+ self
+ addMorphBack: (BottomRightGripMorph new target: self;position: self position)!
Item was added:
+ ----- Method: BorderedMorph>>addEdgeGrips (in category 'lookenhancements') -----
+ addEdgeGrips
+ "Add resizers along the four edges of the receiver"
+
+ self
+ addMorphBack: (TopGripMorph new target: self;position: self position).
+ self
+ addMorphBack: (BottomGripMorph new target: self;position: self position).
+ self
+ addMorphBack: (RightGripMorph new target: self;position: self position).
+ self
+ addMorphBack: (LeftGripMorph new target: self;position: self position).!
Item was added:
+ ----- Method: BorderedMorph>>addPaneHSplitterBetween:and: (in category 'lookenhancements') -----
+ addPaneHSplitterBetween: topMorph and: bottomMorphs
+
+ | targetY minX maxX splitter |
+ targetY := topMorph layoutFrame bottomFraction.
+
+ minX := (bottomMorphs detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction.
+ maxX := (bottomMorphs detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction.
+ splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself.
+ splitter layoutFrame: (LayoutFrame
+ fractions: (minX @ targetY corner: maxX @ targetY)
+ offsets: (((topMorph layoutFrame leftOffset ifNil: [0]) @ 0 corner: (topMorph layoutFrame rightOffset ifNil: [0]) @ 4) translateBy: 0 @ (topMorph layoutFrame bottomOffset ifNil: [0]))).
+
+ self addMorphBack: (splitter position: self position).!
Item was added:
+ ----- Method: BorderedMorph>>addPaneSplitters (in category 'lookenhancements') -----
+ addPaneSplitters
+ | splitter remaining target targetX sameX minY maxY targetY sameY minX maxX |
+ self removePaneSplitters.
+ self removeCornerGrips.
+
+ remaining := submorphs reject: [:each | each layoutFrame rightFraction = 1].
+ [remaining notEmpty] whileTrue:
+ [target := remaining first.
+ targetX := target layoutFrame rightFraction.
+ sameX := submorphs select: [:each | each layoutFrame rightFraction = targetX].
+ minY := (sameX detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction.
+ maxY := (sameX detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction.
+ splitter := ProportionalSplitterMorph new.
+ splitter layoutFrame: (LayoutFrame
+ fractions: (targetX @ minY corner: targetX @ maxY)
+ offsets: ((0 @ (target layoutFrame topOffset ifNil: [0]) corner: 4 @ (target layoutFrame bottomOffset ifNil: [0])) translateBy: (target layoutFrame rightOffset ifNil: [0]) @ 0)).
+ self addMorphBack: (splitter position: self position).
+ remaining := remaining copyWithoutAll: sameX].
+
+ remaining := submorphs copy reject: [:each | each layoutFrame bottomFraction = 1].
+ [remaining notEmpty]
+ whileTrue: [target := remaining first.
+ targetY := target layoutFrame bottomFraction.
+ sameY := submorphs select: [:each | each layoutFrame bottomFraction = targetY].
+ minX := (sameY detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction.
+ maxX := (sameY detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction.
+ splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself.
+ splitter layoutFrame: (LayoutFrame
+ fractions: (minX @ targetY corner: maxX @ targetY)
+ offsets: (((target layoutFrame leftOffset ifNil: [0]) @ 0 corner: (target layoutFrame rightOffset ifNil: [0]) @ 4) translateBy: 0 @ (target layoutFrame bottomOffset ifNil: [0]))).
+ self addMorphBack: (splitter position: self position).
+ remaining := remaining copyWithoutAll: sameY].
+
+ self linkSubmorphsToSplitters.
+ self splitters do: [:each | each comeToFront].
+ !
Item was added:
+ ----- Method: BorderedMorph>>addPaneVSplitterBetween:and: (in category 'lookenhancements') -----
+ addPaneVSplitterBetween: leftMorph and: rightMorphs
+
+ | targetX minY maxY splitter |
+ targetX := leftMorph layoutFrame rightFraction.
+ minY := (rightMorphs detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction.
+ maxY := (rightMorphs detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction.
+
+ splitter := ProportionalSplitterMorph new.
+ splitter layoutFrame: (LayoutFrame
+ fractions: (targetX @ minY corner: targetX @ maxY)
+ offsets: ((0 @ (leftMorph layoutFrame topOffset ifNil: [0]) corner: (4@ (leftMorph layoutFrame bottomOffset ifNil: [0]))) translateBy: (leftMorph layoutFrame rightOffset ifNil: [0]) @ 0)).
+
+ self addMorphBack: (splitter position: self position).!
Item was added:
+ ----- Method: BorderedMorph>>areasRemainingToFill: (in category 'drawing') -----
+ areasRemainingToFill: aRectangle
+ "Fixed here to test the fillStyle rather than color for translucency.
+ Since can have a translucent fillStyle while the (calculated) color is not."
+
+ self fillStyle isTranslucent
+ ifTrue: [^ Array with: aRectangle].
+ self wantsRoundedCorners
+ ifTrue: [(self borderWidth > 0
+ and: [self borderColor isColor
+ and: [self borderColor isTranslucent]])
+ ifTrue: [^ aRectangle
+ areasOutside: (self innerBounds intersect: self boundsWithinCorners)]
+ ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]]
+ ifFalse: [(self borderWidth > 0
+ and: [self borderColor isColor
+ and: [self borderColor isTranslucent]])
+ ifTrue: [^ aRectangle areasOutside: self innerBounds]
+ ifFalse: [^ aRectangle areasOutside: self bounds]]
+ !
Item was added:
+ ----- Method: BorderedMorph>>borderColor (in category 'accessing') -----
+ borderColor
+ ^ borderColor!
Item was added:
+ ----- Method: BorderedMorph>>borderColor: (in category 'accessing') -----
+ borderColor: colorOrSymbolOrNil
+ self doesBevels ifFalse:[
+ colorOrSymbolOrNil isColor ifFalse:[^self]].
+ borderColor = colorOrSymbolOrNil ifFalse: [
+ borderColor := colorOrSymbolOrNil.
+ self changed].
+ !
Item was added:
+ ----- Method: BorderedMorph>>borderInitialize (in category 'initialization') -----
+ borderInitialize
+ "initialize the receiver state related to border"
+ borderColor:= self defaultBorderColor.
+ borderWidth := self defaultBorderWidth!
Item was added:
+ ----- Method: BorderedMorph>>borderInset (in category 'accessing') -----
+ borderInset
+ self borderColor: #inset!
Item was added:
+ ----- Method: BorderedMorph>>borderRaised (in category 'accessing') -----
+ borderRaised
+ self borderColor: #raised!
Item was added:
+ ----- Method: BorderedMorph>>borderStyle (in category 'accessing') -----
+ borderStyle
+ "Work around the borderWidth/borderColor pair"
+
+ | style |
+ borderColor ifNil: [^BorderStyle default].
+ borderWidth isZero ifTrue: [^BorderStyle default].
+ style := self valueOfProperty: #borderStyle ifAbsent: [BorderStyle default].
+ (borderWidth = style width and:
+ ["Hah!! Try understanding this..."
+
+ borderColor == style style or:
+ ["#raised/#inset etc"
+
+ #simple == style style and: [borderColor = style color]]])
+ ifFalse:
+ [style := borderColor isColor
+ ifTrue: [BorderStyle width: borderWidth color: borderColor]
+ ifFalse: [(BorderStyle perform: borderColor) width: borderWidth "argh."].
+ self setProperty: #borderStyle toValue: style].
+ ^style trackColorFrom: self!
Item was added:
+ ----- Method: BorderedMorph>>borderStyle: (in category 'accessing') -----
+ borderStyle: aBorderStyle
+ "Work around the borderWidth/borderColor pair"
+
+ aBorderStyle = self borderStyle ifTrue: [^self].
+ "secure against invalid border styles"
+ (self canDrawBorder: aBorderStyle)
+ ifFalse:
+ ["Replace the suggested border with a simple one"
+
+ ^self borderStyle: (BorderStyle width: aBorderStyle width
+ color: (aBorderStyle trackColorFrom: self) color)].
+ aBorderStyle width = self borderStyle width ifFalse: [self changed].
+ (aBorderStyle isNil or: [aBorderStyle == BorderStyle default])
+ ifTrue:
+ [self removeProperty: #borderStyle.
+ borderWidth := 0.
+ ^self changed].
+ self setProperty: #borderStyle toValue: aBorderStyle.
+ borderWidth := aBorderStyle width.
+ borderColor := aBorderStyle style == #simple
+ ifTrue: [aBorderStyle color]
+ ifFalse: [aBorderStyle style].
+ self changed!
Item was added:
+ ----- Method: BorderedMorph>>borderWidth (in category 'accessing') -----
+ borderWidth
+ ^ borderWidth!
Item was added:
+ ----- Method: BorderedMorph>>borderWidth: (in category 'accessing') -----
+ borderWidth: anInteger
+ borderColor ifNil: [borderColor := Color black].
+ borderWidth := anInteger max: 0.
+ self changed!
Item was added:
+ ----- Method: BorderedMorph>>changeBorderColor: (in category 'menu') -----
+ changeBorderColor: evt
+ | aHand |
+ aHand := evt ifNotNil: [evt hand] ifNil: [self primaryHand].
+ self changeColorTarget: self selector: #borderColor: originalColor: self borderColor hand: aHand!
Item was added:
+ ----- Method: BorderedMorph>>changeBorderWidth: (in category 'menu') -----
+ changeBorderWidth: evt
+ | handle origin aHand newWidth oldWidth |
+ aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand].
+ origin := aHand position.
+ oldWidth := borderWidth.
+ (handle := HandleMorph new)
+ forEachPointDo:
+ [:newPoint | handle removeAllMorphs.
+ handle addMorph:
+ (LineMorph from: origin to: newPoint color: Color black width: 1).
+ newWidth := (newPoint - origin) r asInteger // 5.
+ self borderWidth: newWidth]
+ lastPointDo:
+ [:newPoint | handle deleteBalloon.
+ self halo ifNotNil: [:halo | halo addHandles].
+ self rememberCommand:
+ (Command new cmdWording: 'border change' translated;
+ undoTarget: self selector: #borderWidth: argument: oldWidth;
+ redoTarget: self selector: #borderWidth: argument: newWidth)].
+ aHand attachMorph: handle.
+ handle setProperty: #helpAtCenter toValue: true.
+ handle showBalloon:
+ 'Move cursor farther from
+ this point to increase border width.
+ Click when done.' translated hand: evt hand.
+ handle startStepping!
Item was added:
+ ----- Method: BorderedMorph>>closestPointTo: (in category 'geometry') -----
+ closestPointTo: aPoint
+ "account for round corners. Still has a couple of glitches at upper left and right corners"
+ | pt |
+ pt := self bounds pointNearestTo: aPoint.
+ self wantsRoundedCorners ifFalse: [ ^pt ].
+ self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in |
+ (pt - out) abs < (6 at 6)
+ ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ].
+ ].
+ ^pt.!
Item was added:
+ ----- Method: BorderedMorph>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ Color black!
Item was added:
+ ----- Method: BorderedMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 2!
Item was added:
+ ----- Method: BorderedMorph>>doesBevels (in category 'accessing') -----
+ doesBevels
+ "To return true means that this object can show bevelled borders, and
+ therefore can accept, eg, #raised or #inset as valid borderColors.
+ Must be overridden by subclasses that do not support bevelled borders."
+
+ ^ true!
Item was added:
+ ----- Method: BorderedMorph>>hasTranslucentColor (in category 'accessing') -----
+ hasTranslucentColor
+ "Answer true if this any of this morph is translucent but not transparent."
+
+ (color isColor and: [color isTranslucentColor]) ifTrue: [^ true].
+ (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [^ true].
+ ^ false
+ !
Item was added:
+ ----- Method: BorderedMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self borderInitialize!
Item was added:
+ ----- Method: BorderedMorph>>intersectionWithLineSegmentFromCenterTo: (in category 'geometry') -----
+ intersectionWithLineSegmentFromCenterTo: aPoint
+ "account for round corners. Still has a couple of glitches at upper left and right corners"
+ | pt |
+ pt := super intersectionWithLineSegmentFromCenterTo: aPoint.
+ self wantsRoundedCorners ifFalse: [ ^pt ].
+ self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in |
+ (pt - out) abs < (6 at 6)
+ ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ].
+ ].
+ ^pt.!
Item was added:
+ ----- Method: BorderedMorph>>linkSubmorphsToSplitters (in category 'lookenhancements') -----
+ linkSubmorphsToSplitters
+
+ self splitters do:
+ [:each |
+ each splitsTopAndBottom
+ ifTrue:
+ [self submorphsDo:
+ [:eachMorph |
+ (eachMorph ~= each and: [eachMorph layoutFrame bottomFraction = each layoutFrame topFraction]) ifTrue: [each addLeftOrTop: eachMorph].
+ (eachMorph ~= each and: [eachMorph layoutFrame topFraction = each layoutFrame bottomFraction]) ifTrue: [each addRightOrBottom: eachMorph]]]
+ ifFalse:
+ [self submorphsDo:
+ [:eachMorph |
+ (eachMorph ~= each and: [eachMorph layoutFrame rightFraction = each layoutFrame leftFraction]) ifTrue: [each addLeftOrTop: eachMorph].
+ (eachMorph ~= each and: [eachMorph layoutFrame leftFraction = each layoutFrame rightFraction]) ifTrue: [each addRightOrBottom: eachMorph]]]]!
Item was added:
+ ----- Method: BorderedMorph>>removeCornerGrips (in category 'lookenhancements') -----
+ removeCornerGrips
+
+ | corners |
+ corners := self submorphsSatisfying: [:each | each isKindOf: CornerGripMorph].
+ corners do: [:each | each delete]!
Item was added:
+ ----- Method: BorderedMorph>>removePaneSplitters (in category 'lookenhancements') -----
+ removePaneSplitters
+
+ self splitters do: [:each | each delete]!
Item was added:
+ ----- Method: BorderedMorph>>setBorderWidth:borderColor: (in category 'private') -----
+ setBorderWidth: w borderColor: bc
+ self borderWidth: w.
+ self borderColor: bc.!
Item was added:
+ ----- Method: BorderedMorph>>setColor:borderWidth:borderColor: (in category 'private') -----
+ setColor: c borderWidth: w borderColor: bc
+ self color: c.
+ self borderWidth: w.
+ self borderColor: bc.!
Item was added:
+ ----- Method: BorderedMorph>>splitters (in category 'lookenhancements') -----
+ splitters
+
+ ^ self submorphsSatisfying: [:each | each isKindOf: ProportionalSplitterMorph]!
Item was added:
+ ----- Method: BorderedMorph>>useRoundedCorners (in category 'accessing') -----
+ useRoundedCorners
+ self cornerStyle: #rounded!
Item was added:
+ ----- Method: BorderedMorph>>useSquareCorners (in category 'accessing') -----
+ useSquareCorners
+ self cornerStyle: #square!
Item was added:
+ BorderedMorph subclass: #BorderedSubpaneDividerMorph
+ instanceVariableNames: 'resizingEdge'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph class>>forBottomEdge (in category 'as yet unclassified') -----
+ forBottomEdge
+ ^self new horizontal resizingEdge: #bottom!
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph class>>forTopEdge (in category 'as yet unclassified') -----
+ forTopEdge
+ ^self new horizontal resizingEdge: #top!
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph class>>horizontal (in category 'as yet unclassified') -----
+ horizontal
+ ^self new horizontal!
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph class>>vertical (in category 'as yet unclassified') -----
+ vertical
+ ^self new vertical!
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 0!
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color black!
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph>>firstEnter: (in category 'as yet unclassified') -----
+ firstEnter: evt
+ "The first time this divider is activated, find its window and redirect further interaction there."
+ | window |
+
+ window := self firstOwnerSuchThat: [:m | m respondsTo: #secondaryPaneTransition:divider:].
+ window ifNil: [ self suspendEventHandler. ^ self ]. "not working out"
+ window secondaryPaneTransition: evt divider: self.
+ self on: #mouseEnter send: #secondaryPaneTransition:divider: to: window.
+ !
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph>>horizontal (in category 'as yet unclassified') -----
+ horizontal
+
+ self hResizing: #spaceFill.!
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self extent: 1 @ 1!
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph>>resizingEdge (in category 'as yet unclassified') -----
+ resizingEdge
+
+ ^resizingEdge
+ !
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph>>resizingEdge: (in category 'as yet unclassified') -----
+ resizingEdge: edgeSymbol
+
+ (#(top bottom) includes: edgeSymbol) ifFalse:
+ [ self error: 'resizingEdge must be #top or #bottom' ].
+ resizingEdge := edgeSymbol.
+ self on: #mouseEnter send: #firstEnter: to: self.
+ !
Item was added:
+ ----- Method: BorderedSubpaneDividerMorph>>vertical (in category 'as yet unclassified') -----
+ vertical
+
+ self vResizing: #spaceFill.!
Item was added:
+ BorderGripMorph subclass: #BottomGripMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: BottomGripMorph>>apply: (in category 'target resize') -----
+ apply: delta
+ | oldBounds |
+ oldBounds := target bounds.
+ target
+ bounds: (oldBounds origin corner: oldBounds corner + (0 @ delta y))!
Item was added:
+ ----- Method: BottomGripMorph>>defaultHeight (in category 'initialize') -----
+ defaultHeight
+
+ ^ 5!
Item was added:
+ ----- Method: BottomGripMorph>>gripLayoutFrame (in category 'accessing') -----
+ gripLayoutFrame
+ ^ LayoutFrame
+ fractions: (0 @ 1 corner: 1 @ 1)
+ offsets: (0 @ self defaultHeight negated corner: 0@ 0)!
Item was added:
+ ----- Method: BottomGripMorph>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ self hResizing: #spaceFill.!
Item was added:
+ ----- Method: BottomGripMorph>>ptName (in category 'accessing') -----
+ ptName
+ ^#bottom!
Item was added:
+ ----- Method: BottomGripMorph>>resizeCursor (in category 'accessing') -----
+ resizeCursor
+
+ ^ Cursor resizeForEdge: #top!
Item was added:
+ CornerGripMorph subclass: #BottomLeftGripMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !BottomLeftGripMorph commentStamp: 'jmv 1/29/2006 17:17' prior: 0!
+ I am the handle in the left bottom of windows used for resizing them.!
Item was added:
+ ----- Method: BottomLeftGripMorph>>apply: (in category 'target resize') -----
+ apply: delta
+ | oldBounds |
+ oldBounds := target bounds.
+ target
+ bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner + (0 @ delta y))!
Item was added:
+ ----- Method: BottomLeftGripMorph>>borderOffset (in category 'private') -----
+ borderOffset
+ |width|
+ width :=SystemWindow borderWidth +1.
+ ^self handleOrigin + (width @ width negated)!
Item was added:
+ ----- Method: BottomLeftGripMorph>>gripLayoutFrame (in category 'accessing') -----
+ gripLayoutFrame
+ ^ LayoutFrame
+ fractions: (0 @ 1 corner: 0 @ 1)
+ offsets: (0 @ (0 - self defaultHeight) corner: self defaultWidth @ 0)!
Item was added:
+ ----- Method: BottomLeftGripMorph>>handleOrigin (in category 'private') -----
+ handleOrigin
+ ^25 at 0!
Item was added:
+ ----- Method: BottomLeftGripMorph>>ptName (in category 'accessing') -----
+ ptName
+ ^#bottomLeft!
Item was added:
+ ----- Method: BottomLeftGripMorph>>resizeCursor (in category 'accessing') -----
+ resizeCursor
+
+ ^ Cursor resizeForEdge: #bottomLeft!
Item was added:
+ CornerGripMorph subclass: #BottomRightGripMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !BottomRightGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0!
+ I am the handle in the right bottom of windows used for resizing them.!
Item was added:
+ ----- Method: BottomRightGripMorph>>apply: (in category 'target resize') -----
+ apply: delta
+ | oldBounds |
+ oldBounds := target bounds.
+ target
+ bounds: (oldBounds origin corner: oldBounds corner + delta)!
Item was added:
+ ----- Method: BottomRightGripMorph>>borderOffset (in category 'private') -----
+ borderOffset
+ |width|
+ width :=SystemWindow borderWidth +1.
+ ^self handleOrigin - (width asPoint)!
Item was added:
+ ----- Method: BottomRightGripMorph>>gripLayoutFrame (in category 'accessing') -----
+ gripLayoutFrame
+ ^ LayoutFrame
+ fractions: (1 @ 1 corner: 1 @ 1)
+ offsets: (0 - self defaultWidth @ (0 - self defaultHeight) corner: 0 @ 0)!
Item was added:
+ ----- Method: BottomRightGripMorph>>handleOrigin (in category 'private') -----
+ handleOrigin
+ ^0 at 0!
Item was added:
+ ----- Method: BottomRightGripMorph>>ptName (in category 'accessing') -----
+ ptName
+ ^#bottomRight!
Item was added:
+ ----- Method: BottomRightGripMorph>>resizeCursor (in category 'accessing') -----
+ resizeCursor
+
+ ^ Cursor resizeForEdge: #bottomRight!
Item was added:
+ Morph subclass: #BracketMorph
+ instanceVariableNames: 'orientation'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !BracketMorph commentStamp: 'gvc 5/18/2007 13:48' prior: 0!
+ Morph displaying opposing arrows.!
Item was added:
+ ----- Method: BracketMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Draw triangles at the edges."
+
+ |r|
+ r := self horizontal
+ ifTrue: [self bounds insetBy: (2 at 1 corner: 2 at 1)]
+ ifFalse: [self bounds insetBy: (1 at 2 corner: 1 at 2)].
+ aCanvas
+ drawPolygon: (self leftOrTopVertices: self bounds)
+ fillStyle: self borderColor;
+ drawPolygon: (self leftOrTopVertices: r)
+ fillStyle: self fillStyle;
+ drawPolygon: (self rightOrBottomVertices: self bounds)
+ fillStyle: self borderColor;
+ drawPolygon: (self rightOrBottomVertices: r)
+ fillStyle: self fillStyle!
Item was added:
+ ----- Method: BracketMorph>>horizontal (in category 'accessing') -----
+ horizontal
+ "Answer whether horizontal or vertical."
+
+ ^self orientation == #horizontal!
Item was added:
+ ----- Method: BracketMorph>>horizontal: (in category 'accessing') -----
+ horizontal: aBoolean
+ "Set whether horizontal or vertical."
+
+ ^self orientation: (aBoolean ifTrue: [#horizontal] ifFalse: [#vertical])!
Item was added:
+ ----- Method: BracketMorph>>initialize (in category 'initialization') -----
+ initialize
+ "Initialize the receiver."
+
+ super initialize.
+ self
+ orientation: #horizontal!
Item was added:
+ ----- Method: BracketMorph>>leftOrTopVertices: (in category 'geometry') -----
+ leftOrTopVertices: r
+ "Answer the vertices for a left or top bracket in the given rectangle."
+
+ ^self orientation == #vertical
+ ifTrue: [{r topLeft - (0 at 1). r left + (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)).
+ r left + (r height // 2 + (r height \\ 2))@(r center y). r bottomLeft}]
+ ifFalse: [{r topLeft. (r center x - (r width + 1 \\ 2))@(r top + (r width // 2 + (r width \\ 2))).
+ r center x@(r top + (r width // 2 + (r width \\ 2))). r topRight}]!
Item was added:
+ ----- Method: BracketMorph>>orientation (in category 'accessing') -----
+ orientation
+ "Answer the value of orientation"
+
+ ^ orientation!
Item was added:
+ ----- Method: BracketMorph>>orientation: (in category 'accessing') -----
+ orientation: anObject
+ "Set the value of orientation"
+
+ orientation := anObject.
+ self changed!
Item was added:
+ ----- Method: BracketMorph>>rightOrBottomVertices: (in category 'geometry') -----
+ rightOrBottomVertices: r
+ "Answer the vertices for a right or bottom bracket in the given rectangle."
+
+ ^self orientation == #vertical
+ ifTrue: [{r topRight - (0 at 1). r right - (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)).
+ r right - (r height // 2 + (r height \\ 2))@(r center y). r bottomRight}]
+ ifFalse: [{(r center x)@(r bottom - 1 - (r width // 2 + (r width \\ 2))).
+ r center x @(r bottom - 1 - (r width // 2 + (r width \\ 2))). r bottomRight. r bottomLeft - (1 at 0)}]!
Item was added:
+ Slider subclass: #BracketSliderMorph
+ instanceVariableNames: 'getEnabledSelector enabled'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !BracketSliderMorph commentStamp: 'gvc 5/18/2007 13:39' prior: 0!
+ Abstract superclass for morphs that are used to select a component (R, G, B or A) of a colour.!
Item was added:
+ ----- Method: BracketSliderMorph>>adoptPaneColor: (in category 'accessing - ui') -----
+ adoptPaneColor: paneColor
+ "Pass on to the border too."
+ super adoptPaneColor: paneColor.
+ paneColor ifNil: [ ^ self ].
+ self
+ fillStyle: self fillStyleToUse ;
+ borderStyle:
+ (BorderStyle inset
+ width: 1 ;
+ baseColor: self color twiceDarker) ;
+ sliderColor:
+ (self enabled
+ ifTrue: [ paneColor twiceDarker ]
+ ifFalse: [ self paneColor twiceDarker paler ])!
Item was added:
+ ----- Method: BracketSliderMorph>>borderStyleToUse (in category 'accessing - ui') -----
+ borderStyleToUse
+ "Answer the borderStyle that should be used for the receiver."
+
+ ^self enabled
+ ifTrue: [self theme sliderNormalBorderStyleFor: self]
+ ifFalse: [self theme sliderDisabledBorderStyleFor: self]!
Item was added:
+ ----- Method: BracketSliderMorph>>defaultColor (in category 'accessing - ui') -----
+ defaultColor
+ "Answer the default color/fill style for the receiver."
+
+ ^Color white!
Item was added:
+ ----- Method: BracketSliderMorph>>defaultFillStyle (in category 'accessing - ui') -----
+ defaultFillStyle
+ "Answer the defauolt fill style."
+
+ ^Color gray!
Item was added:
+ ----- Method: BracketSliderMorph>>disable (in category 'as yet unclassified') -----
+ disable
+ "Disable the receiver."
+
+ self enabled: false!
Item was added:
+ ----- Method: BracketSliderMorph>>enable (in category 'as yet unclassified') -----
+ enable
+ "Enable the receiver."
+
+ self enabled: true!
Item was added:
+ ----- Method: BracketSliderMorph>>enabled (in category 'accessing') -----
+ enabled
+ "Answer the value of enabled"
+
+ ^ enabled!
Item was added:
+ ----- Method: BracketSliderMorph>>enabled: (in category 'accessing') -----
+ enabled: anObject
+ "Set the value of enabled"
+
+ enabled = anObject ifTrue: [^self].
+ enabled := anObject.
+ self changed: #enabled.
+ self
+ adoptPaneColor: self color;
+ changed!
Item was added:
+ ----- Method: BracketSliderMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "Update the gradient directions."
+
+ super extent: aPoint.
+ self updateFillStyle!
Item was added:
+ ----- Method: BracketSliderMorph>>fillStyleToUse (in category 'accessing - ui') -----
+ fillStyleToUse
+ "Answer the fillStyle that should be used for the receiver."
+
+ ^self fillStyle!
Item was added:
+ ----- Method: BracketSliderMorph>>getEnabledSelector (in category 'accessing') -----
+ getEnabledSelector
+ "Answer the value of getEnabledSelector"
+
+ ^ getEnabledSelector!
Item was added:
+ ----- Method: BracketSliderMorph>>getEnabledSelector: (in category 'accessing') -----
+ getEnabledSelector: aSymbol
+ "Set the value of getEnabledSelector"
+
+ getEnabledSelector := aSymbol.
+ self updateEnabled!
Item was added:
+ ----- Method: BracketSliderMorph>>gradient (in category 'accessing - ui') -----
+ gradient
+ "Answer the gradient."
+
+ self subclassResponsibility!
Item was added:
+ ----- Method: BracketSliderMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ "Answer true."
+
+ ^true!
Item was added:
+ ----- Method: BracketSliderMorph>>initialize (in category 'initialization') -----
+ initialize
+ "Initialize the receiver."
+
+ super initialize.
+ self
+ enabled: true;
+ fillStyle: self defaultFillStyle;
+ borderStyle: (BorderStyle inset baseColor: self color; width: 1);
+ sliderColor: Color black;
+ clipSubmorphs: true!
Item was added:
+ ----- Method: BracketSliderMorph>>initializeSlider (in category 'initialization') -----
+ initializeSlider
+ "Make the slider raised."
+
+ slider :=( BracketMorph newBounds: self totalSliderArea)
+ horizontal: self bounds isWide;
+ color: self thumbColor;
+ borderStyle: (BorderStyle raised baseColor: Color white; width: 1).
+ sliderShadow := (BracketMorph newBounds: self totalSliderArea)
+ horizontal: self bounds isWide;
+ color: self pagingArea color;
+ borderStyle: (BorderStyle inset baseColor: (Color white alpha: 0.6); width: 1).
+ slider on: #mouseMove send: #scrollAbsolute: to: self.
+ slider on: #mouseDown send: #mouseDownInSlider: to: self.
+ slider on: #mouseUp send: #mouseUpInSlider: to: self.
+ "(the shadow must have the pagingArea as its owner to highlight properly)"
+ self pagingArea addMorph: sliderShadow.
+ sliderShadow hide.
+ self addMorph: slider.
+ self computeSlider.
+ !
Item was added:
+ ----- Method: BracketSliderMorph>>layoutBounds: (in category 'layout') -----
+ layoutBounds: aRectangle
+ "Set the bounds for laying out children of the receiver.
+ Note: written so that #layoutBounds can be changed without touching this method"
+
+ super layoutBounds: aRectangle.
+ self computeSlider!
Item was added:
+ ----- Method: BracketSliderMorph>>minHeight (in category 'layout') -----
+ minHeight
+ "Answer the receiver's minimum height.
+ Give it a bit of a chance..."
+
+ ^8 max: super minHeight!
Item was added:
+ ----- Method: BracketSliderMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: anEvent
+ "Set the value directly."
+
+ self enabled ifTrue: [
+ self
+ scrollPoint: anEvent;
+ computeSlider].
+ super mouseDown: anEvent.
+ self enabled ifFalse: [^self].
+ anEvent hand newMouseFocus: slider event: anEvent.
+ slider
+ mouseEnter: anEvent copy;
+ mouseDown: anEvent copy
+ !
Item was added:
+ ----- Method: BracketSliderMorph>>mouseDownInSlider: (in category 'other events') -----
+ mouseDownInSlider: event
+ "Ignore if disabled."
+
+ self enabled ifFalse: [^self].
+ ^super mouseDownInSlider: event!
Item was added:
+ ----- Method: BracketSliderMorph>>roomToMove (in category 'geometry') -----
+ roomToMove
+ "Allow to run off the edges a bit."
+
+ ^self bounds isWide
+ ifTrue: [self totalSliderArea insetBy: ((self sliderThickness // 2 at 0) negated corner: (self sliderThickness // 2 + 1)@0)]
+ ifFalse: [self totalSliderArea insetBy: (0@(self sliderThickness // 2) negated corner: 0@(self sliderThickness // 2 - (self sliderThickness \\ 2) + 1))]!
Item was added:
+ ----- Method: BracketSliderMorph>>scrollAbsolute: (in category 'scrolling') -----
+ scrollAbsolute: event
+ "Ignore if disabled."
+
+ self enabled ifFalse: [^self].
+ ^super scrollAbsolute: event!
Item was added:
+ ----- Method: BracketSliderMorph>>scrollPoint: (in category 'event handling') -----
+ scrollPoint: event
+ "Scroll to the event position."
+
+ | r p |
+ r := self roomToMove.
+ bounds isWide
+ ifTrue: [r width = 0 ifTrue: [^ self]]
+ ifFalse: [r height = 0 ifTrue: [^ self]].
+ p := event position - (self sliderThickness // 2) adhereTo: r.
+ self descending
+ ifFalse:
+ [self setValue: (bounds isWide
+ ifTrue: [(p x - r left) asFloat / r width]
+ ifFalse: [(p y - r top) asFloat / r height])]
+ ifTrue:
+ [self setValue: (bounds isWide
+ ifTrue: [(r right - p x) asFloat / r width]
+ ifFalse: [(r bottom - p y) asFloat / r height])]!
Item was added:
+ ----- Method: BracketSliderMorph>>sliderColor: (in category 'accessing - ui') -----
+ sliderColor: newColor
+ "Set the slider colour."
+
+ super sliderColor: (self enabled ifTrue: [Color black] ifFalse: [self sliderShadowColor]).
+ slider ifNotNil: [slider borderStyle baseColor: Color white]!
Item was added:
+ ----- Method: BracketSliderMorph>>sliderShadowColor (in category 'accessing - ui') -----
+ sliderShadowColor
+ "Answer the color for the slider shadow."
+
+ ^Color black alpha: 0.6!
Item was added:
+ ----- Method: BracketSliderMorph>>sliderThickness (in category 'geometry') -----
+ sliderThickness
+ "Answer the thickness of the slider."
+
+ ^((self bounds isWide
+ ifTrue: [self height]
+ ifFalse: [self width]) // 2 max: 8) // 2 * 2 + 1!
Item was added:
+ ----- Method: BracketSliderMorph>>update: (in category 'updating') -----
+ update: aSymbol
+ "Update the value."
+
+ super update: aSymbol.
+ aSymbol == self getEnabledSelector ifTrue: [
+ ^self updateEnabled].!
Item was added:
+ ----- Method: BracketSliderMorph>>updateEnabled (in category 'testing') -----
+ updateEnabled
+ "Update the enablement state."
+
+ self model ifNotNil: [
+ self getEnabledSelector ifNotNil: [
+ self enabled: (self model perform: self getEnabledSelector)]]!
Item was added:
+ ----- Method: BracketSliderMorph>>updateFillStyle (in category 'initialization') -----
+ updateFillStyle
+ "Update the fill style directions."
+
+ |b fs|
+ fs := self fillStyle.
+ fs isOrientedFill ifTrue: [
+ b := self innerBounds.
+ fs origin: b topLeft.
+ fs direction: (b isWide
+ ifTrue: [b width at 0]
+ ifFalse: [0 at b height])]!
Item was added:
+ FlattenEncoder subclass: #Canvas
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !Canvas commentStamp: '<historical>' prior: 0!
+ A canvas is a two-dimensional medium on which morphs are drawn in a device-independent manner. Canvases keep track of the origin and clipping rectangle, as well as the underlying drawing medium (such as a window, pixmap, or postscript script).
+
+ Subclasses must implement (at least) the following methods:
+ * Drawing:
+ #fillOval:color:borderWidth:borderColor:
+ #frameAndFillRectangle:fillColor:borderWidth:borderColor:
+ #drawPolygon:color:borderWidth:borderColor:
+ #image:at:sourceRect:rule:
+ #stencil:at:sourceRect:rule:
+ #line:to:width:color:
+ #paragraph:bounds:color:
+ #text:bounds:font:color:
+ * Support
+ #clipBy:during:
+ #translateBy:during:
+ #translateBy:clippingTo:during:
+ #transformBy:clippingTo:during:
+ !
Item was added:
+ ----- Method: Canvas class>>filterSelector (in category 'configuring') -----
+ filterSelector
+ ^#drawOnCanvas:.!
Item was added:
+ ----- Method: Canvas>>asAlphaBlendingCanvas: (in category 'converting') -----
+ asAlphaBlendingCanvas: alpha
+ ^(AlphaBlendingCanvas on: self) alpha: alpha!
Item was added:
+ ----- Method: Canvas>>asShadowDrawingCanvas (in category 'converting') -----
+ asShadowDrawingCanvas
+ ^self asShadowDrawingCanvas: (Color black alpha: 0.5).!
Item was added:
+ ----- Method: Canvas>>asShadowDrawingCanvas: (in category 'converting') -----
+ asShadowDrawingCanvas: aColor
+ ^(ShadowDrawingCanvas on: self) shadowColor: aColor!
Item was added:
+ ----- Method: Canvas>>cache:using:during: (in category 'drawing-support') -----
+ cache: aRectangle using: aCache during: aBlock
+ "Cache the execution of aBlock by the given cache.
+ Note: At some point we may want to actually *create* the cache here;
+ for now we're only using it."
+
+ (aCache notNil
+ and: [(aCache isForm) and: [aCache extent = aRectangle extent]])
+ ifTrue: [^self paintImage: aCache at: aRectangle origin].
+ aBlock value: self!
Item was added:
+ ----- Method: Canvas>>clipBy:during: (in category 'drawing-support') -----
+ clipBy: aRectangle during: aBlock
+ "Set a clipping rectangle active only during the execution of aBlock.
+ Note: In the future we may want to have more general clip shapes - not just rectangles"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>clipRect (in category 'accessing') -----
+ clipRect
+ "Return the currently active clipping rectangle"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>contentsOfArea: (in category 'accessing') -----
+ contentsOfArea: aRectangle
+ "Return the contents of the given area"
+ ^self contentsOfArea: aRectangle into: (Form extent: aRectangle extent depth: self depth)!
Item was added:
+ ----- Method: Canvas>>contentsOfArea:into: (in category 'accessing') -----
+ contentsOfArea: aRectangle into: aForm
+ "Return the contents of the given area"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>copy (in category 'copying') -----
+ copy
+
+ ^ self clone
+ !
Item was added:
+ ----- Method: Canvas>>copyClipRect: (in category 'copying') -----
+ copyClipRect: newClipRect
+
+ ^ ClippingCanvas canvas: self clipRect: newClipRect
+ !
Item was added:
+ ----- Method: Canvas>>depth (in category 'accessing') -----
+ depth
+
+ ^ Display depth
+ !
Item was added:
+ ----- Method: Canvas>>displayIsFullyUpdated (in category 'Nebraska/embeddedWorlds') -----
+ displayIsFullyUpdated!
Item was added:
+ ----- Method: Canvas>>doesRoundedCorners (in category 'testing') -----
+ doesRoundedCorners
+
+ ^ true!
Item was added:
+ ----- Method: Canvas>>draw: (in category 'drawing-general') -----
+ draw: anObject
+ ^anObject drawOn: self!
Item was added:
+ ----- Method: Canvas>>drawImage:at: (in category 'drawing-images') -----
+ drawImage: aForm at: aPoint
+ "Draw the given Form, which is assumed to be a Form or ColorForm"
+
+ self drawImage: aForm
+ at: aPoint
+ sourceRect: aForm boundingBox!
Item was added:
+ ----- Method: Canvas>>drawImage:at:sourceRect: (in category 'drawing-images') -----
+ drawImage: aForm at: aPoint sourceRect: sourceRect
+ "Draw the given form."
+ self shadowColor ifNotNil:[
+ ^self fillRectangle: ((aForm boundingBox intersect: sourceRect) translateBy: aPoint)
+ color: self shadowColor].
+ ^self image: aForm
+ at: aPoint
+ sourceRect: sourceRect
+ rule: Form over!
Item was added:
+ ----- Method: Canvas>>drawMorph: (in category 'drawing-general') -----
+ drawMorph: aMorph
+ self draw: aMorph!
Item was added:
+ ----- Method: Canvas>>drawPolygon:color:borderWidth:borderColor: (in category 'drawing-polygons') -----
+ drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
+ "Draw the given polygon."
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>drawPolygon:fillStyle: (in category 'drawing-polygons') -----
+ drawPolygon: vertices fillStyle: aFillStyle
+ "Fill the given polygon."
+ self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent!
Item was added:
+ ----- Method: Canvas>>drawPolygon:fillStyle:borderWidth:borderColor: (in category 'drawing-polygons') -----
+ drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc
+ "Fill the given polygon.
+ Note: The default implementation does not recognize any enhanced fill styles"
+ self drawPolygon: vertices color: aFillStyle asColor borderWidth: bw borderColor: bc!
Item was added:
+ ----- Method: Canvas>>drawString:at: (in category 'drawing-text') -----
+ drawString: s at: pt
+
+ ^ self drawString: s from: 1 to: s size at: pt font: nil color: Color black!
Item was added:
+ ----- Method: Canvas>>drawString:at:font:color: (in category 'drawing-text') -----
+ drawString: s at: pt font: aFont color: aColor
+
+ ^ self drawString: s from: 1 to: s size at: pt font: aFont color: aColor!
Item was added:
+ ----- Method: Canvas>>drawString:from:to:at:font:color: (in category 'drawing-text') -----
+ drawString: s from: firstIndex to: lastIndex at: pt font: font color: aColor
+ self drawString: s from: firstIndex to: lastIndex in: (pt extent: 10000 at 10000) font: font color: aColor!
Item was added:
+ ----- Method: Canvas>>drawString:from:to:in:font:color: (in category 'drawing-text') -----
+ drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>drawString:in: (in category 'drawing-text') -----
+ drawString: s in: boundsRect
+ ^self drawString: s from: 1 to: s size in: boundsRect font: nil color: Color black!
Item was added:
+ ----- Method: Canvas>>drawString:in:font:color: (in category 'drawing-text') -----
+ drawString: s in: boundsRect font: fontOrNil color: c
+ ^self drawString: s from: 1 to: s size in: boundsRect font: fontOrNil color: c!
Item was added:
+ ----- Method: Canvas>>extent (in category 'accessing') -----
+ extent
+ "Return the physical extent of the output device"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>fillColor: (in category 'drawing') -----
+ fillColor: aColor
+ "Fill the receiver with the given color.
+ Note: This method should be named differently since it is intended to fill the background and thus fills even if the color is transparent"
+ ^self fillRectangle: self clipRect color: (aColor alpha: 1.0).!
Item was added:
+ ----- Method: Canvas>>fillOval:color: (in category 'drawing-ovals') -----
+ fillOval: r color: c
+
+ self fillOval: r color: c borderWidth: 0 borderColor: Color transparent.
+ !
Item was added:
+ ----- Method: Canvas>>fillOval:color:borderWidth:borderColor: (in category 'drawing-ovals') -----
+ fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
+ "Fill the given oval."
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>fillOval:fillStyle: (in category 'drawing-ovals') -----
+ fillOval: aRectangle fillStyle: aFillStyle
+ "Fill the given oval."
+ ^self fillOval: aRectangle fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent!
Item was added:
+ ----- Method: Canvas>>fillOval:fillStyle:borderWidth:borderColor: (in category 'drawing-ovals') -----
+ fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
+ "Fill the given oval.
+ Note: The default implementation does not recognize any enhanced fill styles"
+ self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc!
Item was added:
+ ----- Method: Canvas>>fillRectangle:color: (in category 'drawing-rectangles') -----
+ fillRectangle: r color: c
+ "Fill the rectangle using the given color"
+ ^self
+ frameAndFillRectangle: r
+ fillColor: c
+ borderWidth: 0
+ borderColor: Color transparent!
Item was added:
+ ----- Method: Canvas>>fillRectangle:fillStyle: (in category 'drawing-rectangles') -----
+ fillRectangle: aRectangle fillStyle: aFillStyle
+ "Fill the given rectangle.
+ Note: The default implementation does not recognize any enhanced fill styles"
+ self fillRectangle: aRectangle color: aFillStyle asColor.!
Item was added:
+ ----- Method: Canvas>>fillRectangle:fillStyle:borderStyle: (in category 'drawing-rectangles') -----
+ fillRectangle: aRectangle fillStyle: aFillStyle borderStyle: aBorderStyle
+ "Fill the given rectangle."
+ aFillStyle isTransparent ifFalse:[
+ self fillRectangle: (aRectangle insetBy: aBorderStyle width) fillStyle: aFillStyle].
+ aBorderStyle ifNil:[^self].
+ aBorderStyle width <= 0 ifTrue:[^self].
+ aBorderStyle frameRectangle: aRectangle on: self
+ !
Item was added:
+ ----- Method: Canvas>>fillRoundRect:radius:fillStyle: (in category 'drawing-rectangles') -----
+ fillRoundRect: aRectangle radius: radius fillStyle: fillStyle
+
+ self
+ fillRectangle: aRectangle
+ fillStyle: fillStyle.!
Item was added:
+ ----- Method: Canvas>>finish (in category 'initialization') -----
+ finish
+ "If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."
+ ^self flush!
Item was added:
+ ----- Method: Canvas>>finish: (in category 'initialization') -----
+ finish: allDamage
+ "If there are any pending operations on the receiver complete them.
+ Do not return before all modifications have taken effect."
+ ^self finish!
Item was added:
+ ----- Method: Canvas>>flush (in category 'initialization') -----
+ flush!
Item was added:
+ ----- Method: Canvas>>flushDisplay (in category 'other') -----
+ flushDisplay
+ " Dummy ."!
Item was added:
+ ----- Method: Canvas>>forceToScreen: (in category 'other') -----
+ forceToScreen:rect
+ " dummy "
+ !
Item was added:
+ ----- Method: Canvas>>form (in category 'accessing') -----
+ form
+
+ ^ Display
+ !
Item was added:
+ ----- Method: Canvas>>frameAndFillRectangle:fillColor:borderWidth:borderColor: (in category 'drawing-rectangles') -----
+ frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
+ "Draw the rectangle using the given attributes"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>frameAndFillRectangle:fillColor:borderWidth:topLeftColor:bottomRightColor: (in category 'drawing-rectangles') -----
+ frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
+ "Draw the rectangle using the given attributes.
+ Note: This is a *very* simple implementation"
+ | bw pt |
+ self frameAndFillRectangle: r
+ fillColor: fillColor
+ borderWidth: borderWidth
+ borderColor: bottomRightColor.
+ bottomRightColor = topLeftColor ifFalse: [
+ bw := borderWidth asPoint.
+ pt := r topLeft + (bw // 2).
+ self line: pt to: pt + ((r extent x - bw x)@0) width: borderWidth color: topLeftColor.
+ self line: pt to: pt + (0@(r extent y - bw y)) width: borderWidth color: topLeftColor.
+ ].!
Item was added:
+ ----- Method: Canvas>>frameAndFillRoundRect:radius:fillStyle:borderWidth:borderColor: (in category 'drawing-rectangles') -----
+ frameAndFillRoundRect: aRectangle radius: cornerRadius fillStyle: fillStyle borderWidth: bw borderColor: bc
+
+ self
+ frameAndFillRectangle: aRectangle
+ fillColor: fillStyle asColor
+ borderWidth: bw
+ borderColor: bc.!
Item was added:
+ ----- Method: Canvas>>frameOval:color: (in category 'drawing-ovals') -----
+ frameOval: r color: c
+
+ self fillOval: r color: Color transparent borderWidth: 1 borderColor: c.
+ !
Item was added:
+ ----- Method: Canvas>>frameOval:width:color: (in category 'drawing-ovals') -----
+ frameOval: r width: w color: c
+
+ self fillOval: r color: Color transparent borderWidth: w borderColor: c.
+ !
Item was added:
+ ----- Method: Canvas>>frameRectangle:color: (in category 'drawing-rectangles') -----
+ frameRectangle: r color: c
+
+ self frameRectangle: r width: 1 color: c.
+ !
Item was added:
+ ----- Method: Canvas>>frameRectangle:width:color: (in category 'drawing-rectangles') -----
+ frameRectangle: r width: w color: c
+ ^self frameAndFillRectangle: r fillColor: Color transparent borderWidth: w borderColor: c.!
Item was added:
+ ----- Method: Canvas>>frameRoundRect:radius:width:color: (in category 'drawing-rectangles') -----
+ frameRoundRect: aRectangle radius: radius width: borderWidth color: borderColor
+
+ self
+ frameRectangle: aRectangle
+ width: borderWidth
+ color: borderColor.!
Item was added:
+ ----- Method: Canvas>>fullDraw: (in category 'drawing-general') -----
+ fullDraw: anObject
+ ^anObject fullDrawOn: self!
Item was added:
+ ----- Method: Canvas>>fullDrawMorph: (in category 'drawing-general') -----
+ fullDrawMorph: aMorph
+ self fullDraw: aMorph!
Item was added:
+ ----- Method: Canvas>>image:at: (in category 'drawing-obsolete') -----
+ image: aForm at: aPoint
+ "Note: This protocol is deprecated. Use #paintImage: instead."
+ self image: aForm
+ at: aPoint
+ sourceRect: aForm boundingBox
+ rule: Form paint.
+ !
Item was added:
+ ----- Method: Canvas>>image:at:rule: (in category 'drawing-obsolete') -----
+ image: aForm at: aPoint rule: combinationRule
+ "Note: This protocol is deprecated. Use one of the explicit image drawing messages (#paintImage, #drawImage) instead."
+ self image: aForm
+ at: aPoint
+ sourceRect: aForm boundingBox
+ rule: combinationRule.
+ !
Item was added:
+ ----- Method: Canvas>>image:at:sourceRect:rule: (in category 'private') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule
+ "Note: The public use of this protocol is deprecated. It will become private. Nobody in the outside world must assume that a thing like a combination rule has any specific effect."
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>image:at:sourceRect:rule:alpha: (in category 'private') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha
+ "Privately used for blending forms w/ constant alpha. Fall back to simpler case by defaul."
+ ^self image: aForm at: aPoint sourceRect: sourceRect rule: rule!
Item was added:
+ ----- Method: Canvas>>imageWithOpaqueWhite:at: (in category 'drawing-obsolete') -----
+ imageWithOpaqueWhite: aForm at: aPoint
+ "Note: This protocol is deprecated. Use #drawImage: instead"
+ self image: aForm
+ at: aPoint
+ sourceRect: (0 at 0 extent: aForm extent)
+ rule: Form over.
+ !
Item was added:
+ ----- Method: Canvas>>isBalloonCanvas (in category 'testing') -----
+ isBalloonCanvas
+ ^false!
Item was added:
+ ----- Method: Canvas>>isPostscriptCanvas (in category 'testing') -----
+ isPostscriptCanvas
+ ^false!
Item was added:
+ ----- Method: Canvas>>isShadowDrawing (in category 'testing') -----
+ isShadowDrawing
+ ^false!
Item was added:
+ ----- Method: Canvas>>isVisible: (in category 'testing') -----
+ isVisible: aRectangle
+ "Return true if the given rectangle is (partially) visible"
+ ^self clipRect intersects: aRectangle
+ !
Item was added:
+ ----- Method: Canvas>>line:to:brushForm: (in category 'drawing') -----
+ line: pt1 to: pt2 brushForm: brush
+ "Obsolete - will be removed in the future"!
Item was added:
+ ----- Method: Canvas>>line:to:color: (in category 'drawing') -----
+ line: pt1 to: pt2 color: c
+
+ self line: pt1 to: pt2 width: 1 color: c.
+ !
Item was added:
+ ----- Method: Canvas>>line:to:width:color: (in category 'drawing') -----
+ line: pt1 to: pt2 width: w color: c
+ "Draw a line using the given width and color"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>line:to:width:color:dashLength:secondColor:secondDashLength:startingOffset: (in category 'drawing') -----
+ line: pt1 to: pt2 width: width color: color1 dashLength: s1 secondColor: color2 secondDashLength: s2 startingOffset: startingOffset
+ "Draw a line using the given width, colors and dash lengths.
+ Originally written by Stephan Rudlof; tweaked by Dan Ingalls
+ to use startingOffset for sliding offset as in 'ants' animations.
+ Returns the sum of the starting offset and the length of this line."
+
+ | dist deltaBig colors nextPhase segmentOffset phase segmentLength startPoint distDone endPoint segLens |
+ dist := pt1 dist: pt2.
+ dist = 0 ifTrue: [^startingOffset].
+ s1 = 0 & (s2 = 0) ifTrue: [^startingOffset].
+ deltaBig := pt2 - pt1.
+ colors := {
+ color1.
+ color2}.
+ segLens := {
+ s1 asFloat.
+ s2 asFloat}.
+ nextPhase := {
+ 2.
+ 1}.
+
+ "Figure out what phase we are in and how far, given startingOffset."
+ segmentOffset := startingOffset \\ (s1 + s2).
+ segmentLength := segmentOffset < s1
+ ifTrue:
+ [phase := 1.
+ s1 - segmentOffset]
+ ifFalse:
+ [phase := 2.
+ s1 + s2 - segmentOffset].
+ startPoint := pt1.
+ distDone := 0.0.
+ [distDone < dist] whileTrue:
+ [segmentLength := segmentLength min: dist - distDone.
+ endPoint := startPoint + (deltaBig * segmentLength / dist).
+ self
+ line: startPoint truncated
+ to: endPoint truncated
+ width: width
+ color: (colors at: phase).
+ distDone := distDone + segmentLength.
+ phase := nextPhase at: phase.
+ startPoint := endPoint.
+ segmentLength := segLens at: phase].
+ ^startingOffset + dist!
Item was added:
+ ----- Method: Canvas>>line:to:width:color:stepWidth:secondWidth:secondColor:secondStepWidth: (in category 'drawing') -----
+ line: pt1 to: pt2 width: w1 color: c1 stepWidth: s1 secondWidth: w2 secondColor: c2 secondStepWidth: s2
+ "Draw a line using the given width, colors and steps; both steps can
+ have different stepWidths (firstStep, secondStep), draw widths and
+ colors."
+ | bigSteps offsetPoint dist p1p2Vec deltaBig delta1 delta2 lastPoint bigStep |
+ s1 = 0 & (s2 = 0) ifTrue: [^ self].
+ dist := pt1 dist: pt2.
+ dist = 0 ifTrue: [^ self].
+ bigStep := s1 + s2.
+ bigSteps := dist / bigStep.
+ p1p2Vec := pt2 - pt1.
+ deltaBig := p1p2Vec / bigSteps.
+ delta1 := deltaBig * (s1 / bigStep).
+ delta2 := deltaBig * (s2 / bigStep).
+ dist <= s1
+ ifTrue:
+ [self
+ line: pt1 rounded
+ to: pt2 rounded
+ width: w1
+ color: c1.
+ ^ self].
+ 0 to: bigSteps truncated - 1 do:
+ [:bigStepIx |
+ self
+ line: (pt1 + (offsetPoint := deltaBig * bigStepIx)) rounded
+ to: (pt1 + (offsetPoint := offsetPoint + delta1)) rounded
+ width: w1
+ color: c1.
+ self
+ line: (pt1 + offsetPoint) rounded
+ to: (pt1 + (offsetPoint + delta2)) rounded
+ width: w2
+ color: c2].
+ "if there was no loop, offsetPoint is nil"
+ lastPoint := pt1 + ((offsetPoint ifNil: [0 @ 0])
+ + delta2).
+ (lastPoint dist: pt2)
+ <= s1
+ ifTrue: [self
+ line: lastPoint rounded
+ to: pt2 rounded
+ width: w1
+ color: c1]
+ ifFalse:
+ [self
+ line: lastPoint rounded
+ to: (lastPoint + delta1) rounded
+ width: w1
+ color: c1.
+ self
+ line: (lastPoint + delta1) rounded
+ to: pt2
+ width: w1
+ color: c2]!
Item was added:
+ ----- Method: Canvas>>origin (in category 'accessing') -----
+ origin
+ "Return the current origin for drawing operations"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>paintImage:at: (in category 'drawing-images') -----
+ paintImage: aForm at: aPoint
+ "Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value."
+
+ self paintImage: aForm
+ at: aPoint
+ sourceRect: aForm boundingBox
+ !
Item was added:
+ ----- Method: Canvas>>paintImage:at:sourceRect: (in category 'drawing-images') -----
+ paintImage: aForm at: aPoint sourceRect: sourceRect
+ "Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value."
+ self shadowColor ifNotNil:[
+ ^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor].
+ ^self image: aForm
+ at: aPoint
+ sourceRect: sourceRect
+ rule: Form paint!
Item was added:
+ ----- Method: Canvas>>paragraph:bounds:color: (in category 'drawing') -----
+ paragraph: paragraph bounds: bounds color: c
+ "Draw the given paragraph"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>point:color: (in category 'drawing') -----
+ point: p color: c
+ "Obsolete - will be removed in the future"!
Item was added:
+ ----- Method: Canvas>>preserveStateDuring: (in category 'drawing-support') -----
+ preserveStateDuring: aBlock
+ "Preserve the full canvas state during the execution of aBlock"
+ ^aBlock value: self copy!
Item was added:
+ ----- Method: Canvas>>render: (in category 'drawing') -----
+ render: anObject
+ "Do some 3D operations with the object if possible"!
Item was added:
+ ----- Method: Canvas>>reset (in category 'initialization') -----
+ reset
+ "Reset the canvas."
+
+ super initWithTarget:self class defaultTarget.
+ !
Item was added:
+ ----- Method: Canvas>>seesNothingOutside: (in category 'testing') -----
+ seesNothingOutside: aRectangle
+ "Return true if this canvas will not touch anything outside aRectangle"
+ ^ aRectangle containsRect: self clipRect
+ !
Item was added:
+ ----- Method: Canvas>>shadowColor (in category 'accessing') -----
+ shadowColor
+ "Return the current override color or nil if no such color exists"
+ ^nil!
Item was added:
+ ----- Method: Canvas>>shadowColor: (in category 'accessing') -----
+ shadowColor: aColor
+ "Set a shadow color. If set this color overrides any client-supplied color."!
Item was added:
+ ----- Method: Canvas>>stencil:at:color: (in category 'drawing-images') -----
+ stencil: stencilForm at: aPoint color: aColor
+ "Flood this canvas with aColor wherever stencilForm has non-zero pixels"
+ ^self stencil: stencilForm
+ at: aPoint
+ sourceRect: stencilForm boundingBox
+ color: aColor!
Item was added:
+ ----- Method: Canvas>>stencil:at:sourceRect:color: (in category 'drawing-images') -----
+ stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
+ "Flood this canvas with aColor wherever stencilForm has non-zero pixels"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>text:at:font:color: (in category 'drawing-text') -----
+ text: s at: pt font: fontOrNil color: c
+ "OBSOLETE"
+ ^ self drawString: s at: pt font: fontOrNil color: c!
Item was added:
+ ----- Method: Canvas>>text:bounds:font:color: (in category 'drawing-text') -----
+ text: s bounds: boundsRect font: fontOrNil color: c
+ "OBSOLETE"
+ ^self drawString: s in: boundsRect font: fontOrNil color: c!
Item was added:
+ ----- Method: Canvas>>transform2By:clippingTo:during:smoothing: (in category 'Nebraska/embeddedWorlds') -----
+ transform2By: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
+
+ "an attempt to use #displayInterpolatedOn: instead of WarpBlt."
+
+ | patchRect subCanvas pureRect biggerPatch biggerClip interForm |
+
+ self flag: #bob. "added to Canvas in hopes it will work for Nebraska"
+ (aDisplayTransform isPureTranslation) ifTrue: [
+ ^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated
+ clipRect: aClipRect)
+ ].
+ "Prepare an appropriate warp from patch to aClipRect"
+ pureRect := (aDisplayTransform globalBoundsToLocal: aClipRect).
+ patchRect := pureRect rounded.
+ patchRect area = 0 ifTrue: [^self]. "oh, well!!"
+ biggerPatch := patchRect expandBy: 1.
+ biggerClip := (aDisplayTransform localBoundsToGlobal: biggerPatch) rounded.
+
+ "Render the submorphs visible in the clipping rectangle, as patchForm"
+ subCanvas := FormCanvas extent: biggerPatch extent depth: self depth.
+ self isShadowDrawing ifTrue: [
+ subCanvas shadowColor: self shadowColor
+ ].
+
+ "this biggerPatch/biggerClip is an attempt to improve positioning of the final image in high magnification conditions. Since we cannot grab fractional pixels from the source, take one extra and then take just the part we need from the expanded form"
+
+ subCanvas
+ translateBy: biggerPatch topLeft negated rounded
+ during: aBlock.
+ interForm := Form extent: biggerClip extent depth: self depth.
+ subCanvas form
+ displayInterpolatedIn: interForm boundingBox
+ on: interForm.
+ self
+ drawImage: interForm
+ at: aClipRect origin
+ sourceRect: (aClipRect origin - biggerClip origin extent: aClipRect extent)
+
+ !
Item was added:
+ ----- Method: Canvas>>transformBy:clippingTo:during: (in category 'drawing-support') -----
+ transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock
+ "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')."
+ ^ self transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: 1
+ !
Item was added:
+ ----- Method: Canvas>>transformBy:clippingTo:during:smoothing: (in category 'drawing-support') -----
+ transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
+ "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')."
+ ^ self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>translateBy:clippingTo:during: (in category 'other') -----
+ translateBy:aPoint clippingTo:aRect during:aBlock
+ ^aBlock value:(self copyOffset:aPoint clipRect:aRect).!
Item was added:
+ ----- Method: Canvas>>translateBy:during: (in category 'drawing-support') -----
+ translateBy: delta during: aBlock
+ "Set a translation only during the execution of aBlock."
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: Canvas>>translateTo:clippingTo:during: (in category 'drawing-support') -----
+ translateTo: newOrigin clippingTo: aRectangle during: aBlock
+ "Set a new origin and clipping rectangle only during the execution of aBlock."
+ self translateBy: newOrigin - self origin
+ clippingTo: (aRectangle translateBy: self origin negated)
+ during: aBlock!
Item was added:
+ ----- Method: Canvas>>translucentImage:at: (in category 'drawing-images') -----
+ translucentImage: aForm at: aPoint
+ "Draw a translucent image using the best available way of representing translucency."
+ self translucentImage: aForm
+ at: aPoint
+ sourceRect: aForm boundingBox!
Item was added:
+ ----- Method: Canvas>>translucentImage:at:sourceRect: (in category 'drawing-images') -----
+ translucentImage: aForm at: aPoint sourceRect: sourceRect
+ "Draw a translucent image using the best available way of representing translucency.
+ Note: This will be fixed in the future."
+ self shadowColor ifNotNil:[
+ ^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor].
+ (self depth < 32 or:[aForm isTranslucent not])
+ ifTrue:[^self paintImage: aForm at: aPoint sourceRect: sourceRect].
+ self image: aForm
+ at: aPoint
+ sourceRect: sourceRect
+ rule: Form blend!
Item was added:
+ ----- Method: Canvas>>warpImage:transform: (in category 'drawing-images') -----
+ warpImage: aForm transform: aTransform
+ "Warp the given form using aTransform"
+ ^self warpImage: aForm transform: aTransform at: 0 at 0!
Item was added:
+ ----- Method: Canvas>>warpImage:transform:at: (in category 'drawing-images') -----
+ warpImage: aForm transform: aTransform at: extraOffset
+ "Warp the given form using aTransform.
+ TODO: Use transform to figure out appropriate cell size"
+ ^self warpImage: aForm transform: aTransform at: extraOffset sourceRect: aForm boundingBox cellSize: 1!
Item was added:
+ ----- Method: Canvas>>warpImage:transform:at:sourceRect:cellSize: (in category 'drawing-images') -----
+ warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize
+ "Warp the given using the appropriate transform and offset."
+ ^self subclassResponsibility!
Item was added:
+ EllipseMorph subclass: #CircleMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !CircleMorph commentStamp: '<historical>' prior: 0!
+ I am a specialization of EllipseMorph that knows enough to remain circular.
+ !
Item was added:
+ ----- Method: CircleMorph class>>newPin (in category 'as yet unclassified') -----
+ newPin
+ "Construct a pin for embedded attachment"
+ "CircleMorph newPin openInHand"
+ ^self new
+ removeAllMorphs;
+ extent: 18 at 18;
+ hResizing: #rigid;
+ vResizing: #rigid;
+ layoutPolicy: nil;
+ color: Color orange lighter;
+ borderColor: Color orange darker;
+ borderWidth: 2;
+ wantsConnectionWhenEmbedded: true;
+ name: 'Pin'!
Item was added:
+ ----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
+ supplementaryPartsDescriptions
+ "Extra items for parts bins"
+
+ ^ {DescriptionForPartsBin
+ formalName: 'Circle1'
+ categoryList: #('Graphics')
+ documentation: 'A circular shape'
+ globalReceiverSymbol: #CircleMorph
+ nativitySelector: #newStandAlone.
+
+ "DescriptionForPartsBin
+ formalName: 'Pin'
+ categoryList: #('Connectors')
+ documentation: 'An attachment point for Connectors that you can embed in another Morph.'
+ globalReceiverSymbol: #NCPinMorph
+ nativitySelector: #newPin."
+ }!
Item was added:
+ ----- Method: CircleMorph>>addFlexShellIfNecessary (in category 'rotate scale and flex') -----
+ addFlexShellIfNecessary
+ "When scaling or rotating from a halo, I can do this without a flex shell"
+
+ ^ self
+ !
Item was added:
+ ----- Method: CircleMorph>>bounds: (in category 'geometry') -----
+ bounds: aRectangle
+ | size |
+ size := aRectangle width min: aRectangle height.
+ super bounds: (Rectangle origin: aRectangle origin extent: size @ size).!
Item was added:
+ ----- Method: CircleMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ | size oldRotationCenter |
+ oldRotationCenter := self rotationCenter.
+ size := aPoint x min: aPoint y.
+ super extent: size @ size.
+ self rotationCenter: oldRotationCenter.!
Item was added:
+ ----- Method: CircleMorph>>heading: (in category 'geometry eToy') -----
+ heading: newHeading
+ "Set the receiver's heading (in eToy terms).
+ Note that circles never use flex shells."
+ self rotationDegrees: newHeading.!
Item was added:
+ ----- Method: CircleMorph>>initialize (in category 'parts bin') -----
+ initialize
+ super initialize.
+ self extent: 40 at 40;
+ color: Color green lighter!
Item was added:
+ ----- Method: CircleMorph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ ^super initializeToStandAlone
+ extent: 40 at 40;
+ color: Color green lighter;
+ yourself!
Item was added:
+ ----- Method: CircleMorph>>privateMoveBy: (in category 'rotate scale and flex') -----
+ privateMoveBy: delta
+ self setProperty: #referencePosition toValue: self referencePosition + delta.
+ self setProperty: #originalCenter toValue: (self valueOfProperty: #originalCenter ifAbsent: [ self center ]) + delta.
+ super privateMoveBy: delta.
+ !
Item was added:
+ ----- Method: CircleMorph>>referencePosition (in category 'geometry eToy') -----
+ referencePosition
+ "Return the current reference position of the receiver"
+ ^ self valueOfProperty: #referencePosition ifAbsent: [ self center ]
+ !
Item was added:
+ ----- Method: CircleMorph>>rotationCenter (in category 'geometry eToy') -----
+ rotationCenter
+ "Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
+ | refPos |
+ refPos := self referencePosition.
+ ^ (refPos - self bounds origin) / self bounds extent asFloatPoint!
Item was added:
+ ----- Method: CircleMorph>>rotationCenter: (in category 'geometry eToy') -----
+ rotationCenter: aPointOrNil
+ "Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
+ | newRef box |
+ aPointOrNil isNil
+ ifTrue: [self removeProperty: #referencePosition.
+ self removeProperty: #originalCenter.
+ self removeProperty: #originalAngle. ]
+ ifFalse: [ box := self bounds.
+ newRef := box origin + (aPointOrNil * box extent).
+ self setRotationCenterFrom: newRef ].
+
+ !
Item was added:
+ ----- Method: CircleMorph>>rotationDegrees (in category 'rotate scale and flex') -----
+ rotationDegrees
+
+ ^ self forwardDirection!
Item was added:
+ ----- Method: CircleMorph>>rotationDegrees: (in category 'rotate scale and flex') -----
+ rotationDegrees: degrees
+ | ref newPos flex origAngle origCenter |
+ ref := self referencePosition.
+ origAngle := self valueOfProperty: #originalAngle ifAbsentPut: [ self heading ].
+ origCenter := self valueOfProperty: #originalCenter ifAbsentPut: [ self center ].
+ flex := (MorphicTransform offset: ref negated)
+ withAngle: (degrees - origAngle) degreesToRadians.
+ newPos := (flex transform: origCenter) - flex offset.
+ self position: (self position + newPos - self center) asIntegerPoint.
+ self setProperty: #referencePosition toValue: ref.
+ self setProperty: #originalAngle toValue: origAngle.
+ self setProperty: #originalCenter toValue: origCenter.
+ self forwardDirection: degrees.
+ self changed.
+ !
Item was added:
+ ----- Method: CircleMorph>>setRotationCenterFrom: (in category 'menus') -----
+ setRotationCenterFrom: aPoint
+ "Called by halo rotation code.
+ Circles store their referencePosition."
+ self setProperty: #referencePosition toValue: aPoint.
+ self setProperty: #originalCenter toValue: self center.
+ self setProperty: #originalAngle toValue: self heading.!
Item was added:
+ ----- Method: CircleMorph>>transformedBy: (in category 'geometry') -----
+ transformedBy: aTransform
+ aTransform isIdentity ifTrue:[^self].
+ ^self center: (aTransform localPointToGlobal: self center).
+ !
Item was added:
+ RectangleMorph subclass: #ClickExerciser
+ instanceVariableNames: 'buttons'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Demo'!
Item was added:
+ ----- Method: ClickExerciser class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ "ClickExerciser descriptionForPartsBin"
+ ^ self partName: 'Exercise Click'
+ categories: #('Demo')
+ documentation: 'An exerciser for click, double-click, and drag-click in morphic'!
Item was added:
+ ----- Method: ClickExerciser>>allSelectors (in category 'accessing') -----
+ allSelectors
+ ^ #( #click: #doubleClick: #doubleClickTimeout: #startDrag:) !
Item was added:
+ ----- Method: ClickExerciser>>alternateBorderColor (in category 'accessing') -----
+ alternateBorderColor
+ "answer the alternate color/fill style for the receiver"
+ ^ Color yellow!
Item was added:
+ ----- Method: ClickExerciser>>alternateColor (in category 'accessing') -----
+ alternateColor
+ "answer the alternate color/fill style for the receiver"
+ ^ Color cyan!
Item was added:
+ ----- Method: ClickExerciser>>alternateSide (in category 'initialization') -----
+ alternateSide
+ "initial extent is square. We return an alternate height/width for drag to manipulate."
+ ^ (self defaultSide asFloat * 1.618) rounded .
+ !
Item was added:
+ ----- Method: ClickExerciser>>balloonText (in category 'accessing') -----
+ balloonText
+ ^ 'Double-click on me to change my color;
+ single-click on me to change border color;
+ hold mouse down within me and then move it to grow
+ or shrink. When I time out my border changes width.
+ Choose which of the above will work
+ by selecting the boxes in the middle.
+ See the boxes balloons.' translated!
Item was added:
+ ----- Method: ClickExerciser>>click: (in category 'event handling') -----
+ click: evt
+ self showBalloon: 'click' hand: evt hand.
+ self borderColor: (self borderColor = self defaultBorderColor ifTrue: [self alternateBorderColor] ifFalse: [self defaultBorderColor])
+ !
Item was added:
+ ----- Method: ClickExerciser>>defaultBorderColor (in category 'accessing') -----
+ defaultBorderColor
+ "answer the alternate color/fill style for the receiver"
+ ^ Color black!
Item was added:
+ ----- Method: ClickExerciser>>defaultColor (in category 'accessing') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color red!
Item was added:
+ ----- Method: ClickExerciser>>defaultSide (in category 'initialization') -----
+ defaultSide
+ "initial extent is square. We return the default height/width."
+ ^ 100 .
+ !
Item was added:
+ ----- Method: ClickExerciser>>doubleClick: (in category 'event handling') -----
+ doubleClick: evt
+ self showBalloon: 'doubleClick' hand: evt hand.
+ self color: ((color = self alternateColor ) ifTrue: [self defaultColor] ifFalse: [self alternateColor])
+ !
Item was added:
+ ----- Method: ClickExerciser>>doubleClickTimeout: (in category 'event handling') -----
+ doubleClickTimeout: evt
+ self showBalloon: 'ClickTimeout' hand: evt hand.
+ self borderWidth: self borderWidth \\ 11 + 2!
Item was added:
+ ----- Method: ClickExerciser>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ ^ true!
Item was added:
+ ----- Method: ClickExerciser>>initButtons (in category 'initialization') -----
+ initButtons
+ | aButton positions |
+ aButton := ThreePhaseButtonMorph checkBox.
+ positions := ((0 at 0) rect: aButton extent negated) corners + self center .
+ buttons := positions collect: [ :p | ThreePhaseButtonMorph checkBox position: p; state: #on ] .
+ buttons with: self allSelectors do: [ :b :s | b balloonText: s asString ] .
+ self removeAllMorphs .
+ self addAllMorphs: buttons .
+ !
Item was added:
+ ----- Method: ClickExerciser>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ self extent: self defaultSide asPoint.
+ self initButtons .!
Item was added:
+ ----- Method: ClickExerciser>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "Do nothing upon mouse-down except inform the hand to watch for a
+ double-click; wait until an ensuing click:, doubleClick:, or drag:
+ message gets dispatched"
+ Preferences disable: #NewClickTest .
+ evt hand
+ waitForClicksOrDrag: self
+ event: evt
+ selectors: self selectors
+ threshold: HandMorph dragThreshold!
Item was added:
+ ----- Method: ClickExerciser>>selectors (in category 'accessing') -----
+ selectors
+ ^ self allSelectors with: buttons collect: [ :s :b | b isOn ifTrue: [ s ] ifFalse: [nil ] ] .!
Item was added:
+ ----- Method: ClickExerciser>>startDrag: (in category 'event handling') -----
+ startDrag: evt
+ "We'll get a mouseDown first, some mouseMoves, and a mouseUp event last"
+ | height width both |
+ "evt isMouseDown ifTrue:
+ [self showBalloon: 'drag (mouse down)' hand: evt hand.
+ self world displayWorld.
+ (Delay forMilliseconds: 750) wait].
+ evt isMouseUp ifTrue:
+ [self showBalloon: 'drag (mouse up)' hand: evt hand].
+ (evt isMouseUp or: [evt isMouseDown]) ifFalse:
+ [self showBalloon: 'drag (mouse still down)' hand: evt hand].
+ (self containsPoint: evt cursorPoint)
+ ifFalse: [^ self]."
+ self showBalloon: 'drag (mouse down)' hand: evt hand.
+
+ width := (self defaultSide max: self extent x) min: self alternateSide.
+ height := (self defaultSide max: self extent y) min: self alternateSide.
+ both := self defaultSide + self alternateSide.
+
+ self extent:
+ (((color = (self defaultColor)
+ ifTrue:
+ [ (both - height) @ width ]
+ ifFalse:
+ [ height @ (both - width) ])
+ max: self defaultSide asPoint)
+ min: self alternateSide asPoint )
+
+ !
Item was added:
+ PluggableCanvas subclass: #ClippingCanvas
+ instanceVariableNames: 'canvas clipRect'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !ClippingCanvas commentStamp: '<historical>' prior: 0!
+ A modified canvas which clips all drawing commands.!
Item was added:
+ ----- Method: ClippingCanvas class>>canvas:clipRect: (in category 'instance creation') -----
+ canvas: aCanvas clipRect: aRectangle
+ ^self new canvas: aCanvas clipRect: aRectangle!
Item was added:
+ ----- Method: ClippingCanvas>>apply: (in category 'private') -----
+ apply: aBlock
+ "apply the given block to the inner canvas with clipRect as the clipping rectangle"
+ canvas clipBy: clipRect during: aBlock!
Item was added:
+ ----- Method: ClippingCanvas>>canvas:clipRect: (in category 'initialization') -----
+ canvas: aCanvas clipRect: aRectangle
+ canvas := aCanvas.
+ clipRect := aRectangle.!
Item was added:
+ ----- Method: ClippingCanvas>>clipRect (in category 'accessing') -----
+ clipRect
+ ^clipRect!
Item was added:
+ ----- Method: ClippingCanvas>>contentsOfArea:into: (in category 'accessing') -----
+ contentsOfArea: aRectangle into: aForm
+ self flag: #hack. "ignore the clipping specification for this command. This is purely so that CachingCanvas will work properly when clipped. There *has* to be a clean way to do this...."
+ ^canvas contentsOfArea: aRectangle into: aForm!
Item was added:
+ ----- Method: ClippingCanvas>>form (in category 'accessing') -----
+ form
+ ^canvas form!
Item was added:
+ ----- Method: ClippingCanvas>>isBalloonCanvas (in category 'testing') -----
+ isBalloonCanvas
+ ^canvas isBalloonCanvas!
Item was added:
+ ----- Method: ClippingCanvas>>isShadowDrawing (in category 'testing') -----
+ isShadowDrawing
+ ^canvas isShadowDrawing!
Item was added:
+ ----- Method: ClippingCanvas>>shadowColor (in category 'accessing') -----
+ shadowColor
+ ^canvas shadowColor!
Item was added:
+ SystemWindow subclass: #CollapsedMorph
+ instanceVariableNames: 'uncollapsedMorph'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: CollapsedMorph>>beReplacementFor: (in category 'collapse/expand') -----
+ beReplacementFor: aMorph
+
+ | itsWorld priorPosition |
+ (itsWorld := aMorph world) ifNil: [^self].
+ uncollapsedMorph := aMorph.
+
+ self setLabel: aMorph externalName.
+ aMorph delete.
+ itsWorld addMorphFront: self.
+ self collapseOrExpand.
+ (priorPosition := aMorph valueOfProperty: #collapsedPosition ifAbsent: [nil])
+ ifNotNil:
+ [self position: priorPosition].
+ !
Item was added:
+ ----- Method: CollapsedMorph>>buildWindowMenu (in category 'menu') -----
+ buildWindowMenu
+ "Answer the menu to be put up in response to the user's clicking on the window-menu control in the window title. Specialized for CollapsedMorphs."
+
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu add: 'change name...' translated action: #relabel.
+ aMenu addLine.
+ aMenu add: 'send to back' translated action: #sendToBack.
+ aMenu add: 'make next-to-topmost' translated action: #makeSecondTopmost.
+ aMenu addLine.
+ self mustNotClose
+ ifFalse:
+ [aMenu add: 'make unclosable' translated action: #makeUnclosable]
+ ifTrue:
+ [aMenu add: 'make closable' translated action: #makeClosable].
+ aMenu
+ add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) translated
+ action: #toggleStickiness.
+ ^aMenu!
Item was added:
+ ----- Method: CollapsedMorph>>collapseOrExpand (in category 'resize/collapse') -----
+ collapseOrExpand
+ "Toggle the expand/collapsd state of the receiver. If expanding, copy the window title back to the name of the expanded morph"
+
+ | aWorld |
+ isCollapsed
+ ifTrue:
+ [uncollapsedMorph setProperty: #collapsedPosition toValue: self position.
+ labelString ifNotNil: [uncollapsedMorph setNameTo: labelString].
+ mustNotClose := false. "We're not closing but expanding"
+ self delete.
+ (aWorld := self currentWorld) addMorphFront: uncollapsedMorph.
+ aWorld startSteppingSubmorphsOf: uncollapsedMorph]
+ ifFalse:
+ [super collapseOrExpand]!
Item was added:
+ ----- Method: CollapsedMorph>>uncollapseToHand (in category 'collapse/expand') -----
+ uncollapseToHand
+ "Hand the uncollapsedMorph to the user, placing it in her hand, after remembering appropriate state for possible future use"
+
+ | nakedMorph |
+ nakedMorph := uncollapsedMorph.
+ uncollapsedMorph := nil.
+ nakedMorph setProperty: #collapsedPosition toValue: self position.
+ mustNotClose := false. "so the delete will succeed"
+ self delete.
+ ActiveHand attachMorph: nakedMorph!
Item was added:
+ ----- Method: CollapsedMorph>>wantsExpandBox (in category 'resize/collapse') -----
+ wantsExpandBox
+ "Answer whether I'd like an expand box"
+
+ ^ false!
Item was added:
+ ----- Method: Color>>asMorph (in category '*Morphic') -----
+ asMorph
+
+ ^(RectangleMorph new)
+ fillStyle: self;
+ borderWidth: 0;
+ yourself!
Item was added:
+ ----- Method: Color>>iconOrThumbnailOfSize: (in category '*Morphic') -----
+ iconOrThumbnailOfSize: aNumberOrPoint
+ "Answer an appropiate form to represent the receiver"
+ | form |
+ form := Form extent: aNumberOrPoint asPoint asPoint depth: 32.
+ form fillColor: self.
+ ^ form!
Item was added:
+ Canvas subclass: #ColorMappingCanvas
+ instanceVariableNames: 'myCanvas'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: ColorMappingCanvas class>>on: (in category 'instance creation') -----
+ on: aCanvas
+ ^self new on: aCanvas!
Item was added:
+ ----- Method: ColorMappingCanvas>>clipBy:during: (in category 'drawing-support') -----
+ clipBy: aRectangle during: aBlock
+ "Set a clipping rectangle active only during the execution of aBlock.
+ Note: In the future we may want to have more general clip shapes - not just rectangles"
+ | oldCanvas |
+ oldCanvas := myCanvas.
+ myCanvas clipBy: aRectangle during:[:newCanvas|
+ myCanvas := newCanvas.
+ aBlock value: self].
+ myCanvas := oldCanvas!
Item was added:
+ ----- Method: ColorMappingCanvas>>clipRect (in category 'accessing') -----
+ clipRect
+ ^myCanvas clipRect!
Item was added:
+ ----- Method: ColorMappingCanvas>>depth (in category 'accessing') -----
+ depth
+ ^myCanvas depth!
Item was added:
+ ----- Method: ColorMappingCanvas>>drawPolygon:color:borderWidth:borderColor: (in category 'drawing-polygons') -----
+ drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
+ "Draw the given polygon."
+ ^myCanvas
+ drawPolygon: vertices
+ color: aColor
+ borderWidth: bw
+ borderColor: (self mapColor: bc)!
Item was added:
+ ----- Method: ColorMappingCanvas>>drawString:from:to:in:font:color: (in category 'drawing-text') -----
+ drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
+ "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used."
+ myCanvas
+ drawString: s from: firstIndex to: lastIndex
+ in: boundsRect
+ font: fontOrNil
+ color: (self mapColor: c)!
Item was added:
+ ----- Method: ColorMappingCanvas>>extent (in category 'accessing') -----
+ extent
+ ^myCanvas extent!
Item was added:
+ ----- Method: ColorMappingCanvas>>fillOval:color:borderWidth:borderColor: (in category 'drawing-ovals') -----
+ fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
+ "Fill the given oval."
+ myCanvas
+ fillOval: r
+ color: (self mapColor: c)
+ borderWidth: borderWidth
+ borderColor: (self mapColor: borderColor)!
Item was added:
+ ----- Method: ColorMappingCanvas>>flush (in category 'initialization') -----
+ flush
+ myCanvas flush.!
Item was added:
+ ----- Method: ColorMappingCanvas>>form (in category 'accessing') -----
+ form
+ ^myCanvas form!
Item was added:
+ ----- Method: ColorMappingCanvas>>frameAndFillRectangle:fillColor:borderWidth:borderColor: (in category 'drawing-rectangles') -----
+ frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
+ "Draw the rectangle using the given attributes"
+ myCanvas
+ frameAndFillRectangle: r
+ fillColor: (self mapColor: fillColor)
+ borderWidth: borderWidth
+ borderColor: (self mapColor: borderColor)!
Item was added:
+ ----- Method: ColorMappingCanvas>>frameAndFillRectangle:fillColor:borderWidth:topLeftColor:bottomRightColor: (in category 'drawing-rectangles') -----
+ frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
+ "Draw the rectangle using the given attributes"
+ myCanvas
+ frameAndFillRectangle: r
+ fillColor: (self mapColor: fillColor)
+ borderWidth: borderWidth
+ topLeftColor: (self mapColor: topLeftColor)
+ bottomRightColor: (self mapColor: bottomRightColor)!
Item was added:
+ ----- Method: ColorMappingCanvas>>frameAndFillRoundRect:radius:fillStyle:borderWidth:borderColor: (in category 'drawing-rectangles') -----
+ frameAndFillRoundRect: aRectangle radius: cornerRadius fillStyle: fillStyle borderWidth: bw borderColor: bc
+ "Draw the rectangle using the given attributes"
+ myCanvas
+ frameAndFillRoundRect: aRectangle
+ radius: cornerRadius
+ fillStyle: (self mapFillStyle: fillStyle)
+ borderWidth: bw
+ borderColor: (self mapColor: bc)
+ !
Item was added:
+ ----- Method: ColorMappingCanvas>>image:at:sourceRect:rule: (in category 'private') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule
+ "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle."
+ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: rule.!
Item was added:
+ ----- Method: ColorMappingCanvas>>isShadowDrawing (in category 'testing') -----
+ isShadowDrawing
+ ^myCanvas isShadowDrawing!
Item was added:
+ ----- Method: ColorMappingCanvas>>line:to:width:color: (in category 'drawing') -----
+ line: pt1 to: pt2 width: w color: c
+ "Draw a line using the given width and color"
+ myCanvas
+ line: pt1
+ to: pt2
+ width: w
+ color: (self mapColor: c).!
Item was added:
+ ----- Method: ColorMappingCanvas>>mapColor: (in category 'private') -----
+ mapColor: aColor
+ ^aColor!
Item was added:
+ ----- Method: ColorMappingCanvas>>mapFillStyle: (in category 'private') -----
+ mapFillStyle: aFillStyle
+
+ ^ aFillStyle isGradientFill
+ ifFalse: [self mapColor: aFillStyle asColor]
+ ifTrue: [aFillStyle copy colorRamp: (aFillStyle colorRamp collect: [:assoc | assoc key -> (self mapColor: assoc value)])].
+ !
Item was added:
+ ----- Method: ColorMappingCanvas>>on: (in category 'initialization') -----
+ on: aCanvas
+ myCanvas := aCanvas.!
Item was added:
+ ----- Method: ColorMappingCanvas>>origin (in category 'accessing') -----
+ origin
+ ^myCanvas origin!
Item was added:
+ ----- Method: ColorMappingCanvas>>paragraph:bounds:color: (in category 'drawing') -----
+ paragraph: paragraph bounds: bounds color: c
+ "Draw the given paragraph"
+ myCanvas
+ paragraph: paragraph
+ bounds: bounds
+ color: (self mapColor: c)!
Item was added:
+ ----- Method: ColorMappingCanvas>>preserveStateDuring: (in category 'drawing-support') -----
+ preserveStateDuring: aBlock
+ "Preserve the full canvas state during the execution of aBlock"
+ | oldCanvas result |
+ oldCanvas := myCanvas.
+ result := myCanvas preserveStateDuring:[:newCanvas|
+ myCanvas := newCanvas.
+ aBlock value: self].
+ myCanvas := oldCanvas.
+ ^result!
Item was added:
+ ----- Method: ColorMappingCanvas>>reset (in category 'initialization') -----
+ reset
+ myCanvas reset.!
Item was added:
+ ----- Method: ColorMappingCanvas>>stencil:at:color: (in category 'drawing-images') -----
+ stencil: aForm at: aPoint color: aColor
+ myCanvas
+ stencil: aForm
+ at: aPoint
+ color: (self mapColor: aColor)!
Item was added:
+ ----- Method: ColorMappingCanvas>>stencil:at:sourceRect:color: (in category 'drawing-images') -----
+ stencil: aForm at: aPoint sourceRect: aRect color: aColor
+ myCanvas
+ stencil: aForm
+ at: aPoint
+ sourceRect: aRect
+ color: (self mapColor: aColor)!
Item was added:
+ ----- Method: ColorMappingCanvas>>transformBy:clippingTo:during:smoothing: (in category 'drawing-support') -----
+ transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
+
+ "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')."
+ | oldCanvas |
+ oldCanvas := myCanvas.
+ myCanvas transformBy: aDisplayTransform
+ clippingTo: aClipRect
+ during: [:newCanvas |
+ myCanvas := newCanvas.
+ aBlock value: self]
+ smoothing: cellSize.
+ myCanvas := oldCanvas.!
Item was added:
+ ----- Method: ColorMappingCanvas>>translateBy:clippingTo:during: (in category 'other') -----
+ translateBy: delta clippingTo: aRectangle during: aBlock
+ "Set a translation and clipping rectangle only during the execution of aBlock."
+ | oldCanvas |
+ oldCanvas := myCanvas.
+ myCanvas translateBy: delta clippingTo: aRectangle during:[:newCanvas|
+ myCanvas := newCanvas.
+ aBlock value: self].
+ myCanvas := oldCanvas.!
Item was added:
+ ----- Method: ColorMappingCanvas>>translateBy:during: (in category 'drawing-support') -----
+ translateBy: delta during: aBlock
+ "Set a translation only during the execution of aBlock."
+ | oldCanvas |
+ oldCanvas := myCanvas.
+ myCanvas translateBy: delta during:[:newCanvas|
+ myCanvas := newCanvas.
+ aBlock value: self].
+ myCanvas := oldCanvas.!
Item was added:
+ ----- Method: ColorMappingCanvas>>translateTo:clippingTo:during: (in category 'drawing-support') -----
+ translateTo: newOrigin clippingTo: aRectangle during: aBlock
+ "Set a new origin and clipping rectangle only during the execution of aBlock."
+ | oldCanvas |
+ oldCanvas := myCanvas.
+ myCanvas translateTo: newOrigin clippingTo: aRectangle during:[:newCanvas|
+ myCanvas := newCanvas.
+ aBlock value: self].
+ myCanvas := oldCanvas.!
Item was added:
+ FormCanvas subclass: #ColorPatchCanvas
+ instanceVariableNames: 'stopMorph foundMorph doStop'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !ColorPatchCanvas commentStamp: '<historical>' prior: 0!
+ I generate patches of Morphic worlds that views below certain Morphs. This facility is used for the end-user scripting system.!
Item was added:
+ ----- Method: ColorPatchCanvas>>clipBy:during: (in category 'drawing-support') -----
+ clipBy: aRectangle during: aBlock
+ "Set a clipping rectangle active only during the execution of aBlock.
+ Note: In the future we may want to have more general clip shapes - not just rectangles"
+ | tempCanvas |
+ tempCanvas := (self copyClipRect: aRectangle).
+ aBlock value: tempCanvas.
+ foundMorph := tempCanvas foundMorph.!
Item was added:
+ ----- Method: ColorPatchCanvas>>doStop (in category 'accessing') -----
+ doStop
+ ^doStop!
Item was added:
+ ----- Method: ColorPatchCanvas>>doStop: (in category 'accessing') -----
+ doStop: aBoolean
+ doStop := aBoolean!
Item was added:
+ ----- Method: ColorPatchCanvas>>foundMorph (in category 'accessing') -----
+ foundMorph
+ ^foundMorph!
Item was added:
+ ----- Method: ColorPatchCanvas>>foundMorph: (in category 'accessing') -----
+ foundMorph: aBoolean
+ foundMorph := aBoolean!
Item was added:
+ ----- Method: ColorPatchCanvas>>fullDrawMorph: (in category 'drawing-general') -----
+ fullDrawMorph: aMorph
+ (foundMorph and:[doStop]) ifTrue:[^self]. "Found it and should stop"
+ aMorph == stopMorph ifTrue:[
+ "Never draw the stopMorph"
+ foundMorph := true.
+ ^self].
+ ^super fullDrawMorph: aMorph.!
Item was added:
+ ----- Method: ColorPatchCanvas>>preserveStateDuring: (in category 'drawing-support') -----
+ preserveStateDuring: aBlock
+ "Preserve the full canvas state during the execution of aBlock.
+ Note: This does *not* include the state in the receiver (e.g., foundMorph)."
+ | tempCanvas result |
+ tempCanvas := self copy.
+ result := aBlock value: tempCanvas.
+ foundMorph := tempCanvas foundMorph.
+ ^result!
Item was added:
+ ----- Method: ColorPatchCanvas>>reset (in category 'initialization') -----
+ reset
+ "Initialize the receiver to act just as a FormCanvas"
+ super reset.
+ foundMorph := false.
+ doStop := false.
+ stopMorph := nil.!
Item was added:
+ ----- Method: ColorPatchCanvas>>setForm: (in category 'private') -----
+ setForm: aForm
+ "Initialize the receiver to act just as a FormCanvas"
+ super setForm: aForm.
+ stopMorph := nil.
+ doStop := false.
+ foundMorph := false.!
Item was added:
+ ----- Method: ColorPatchCanvas>>stopMorph (in category 'accessing') -----
+ stopMorph
+ ^stopMorph!
Item was added:
+ ----- Method: ColorPatchCanvas>>stopMorph: (in category 'accessing') -----
+ stopMorph: aMorph
+ stopMorph := aMorph!
Item was added:
+ ----- Method: ColorPatchCanvas>>transformBy:clippingTo:during:smoothing: (in category 'drawing-support') -----
+ transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
+ "Note: This method has been originally copied from TransformationMorph."
+ | innerRect patchRect sourceQuad warp start subCanvas |
+ (aDisplayTransform isPureTranslation) ifTrue:[
+ subCanvas := self copyOffset: aDisplayTransform offset negated truncated
+ clipRect: aClipRect.
+ aBlock value: subCanvas.
+ foundMorph := subCanvas foundMorph.
+ ^self
+ ].
+ "Prepare an appropriate warp from patch to innerRect"
+ innerRect := aClipRect.
+ patchRect := aDisplayTransform globalBoundsToLocal:
+ (self clipRect intersect: innerRect).
+ sourceQuad := (aDisplayTransform sourceQuadFor: innerRect)
+ collect: [:p | p - patchRect topLeft].
+ warp := self warpFrom: sourceQuad toRect: innerRect.
+ warp cellSize: cellSize.
+
+ "Render the submorphs visible in the clipping rectangle, as patchForm"
+ start := (self depth = 1 and: [self isShadowDrawing not])
+ "If this is true B&W, then we need a first pass for erasure."
+ ifTrue: [1] ifFalse: [2].
+ start to: 2 do:
+ [:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W"
+ subCanvas := ColorPatchCanvas extent: patchRect extent depth: self depth.
+ subCanvas stopMorph: stopMorph.
+ subCanvas foundMorph: foundMorph.
+ subCanvas doStop: doStop.
+ i=1 ifTrue: [subCanvas shadowColor: Color black.
+ warp combinationRule: Form erase]
+ ifFalse: [self isShadowDrawing ifTrue:
+ [subCanvas shadowColor: self shadowColor].
+ warp combinationRule: Form paint].
+ subCanvas
+ translateBy: patchRect topLeft negated
+ during: aBlock.
+ i = 2 ifTrue:[foundMorph := subCanvas foundMorph].
+ warp sourceForm: subCanvas form; warpBits.
+ warp sourceForm: nil. subCanvas := nil "release space for next loop"]
+ !
Item was added:
+ ----- Method: ColorPatchCanvas>>translateBy:clippingTo:during: (in category 'other') -----
+ translateBy: delta clippingTo: aRectangle during: aBlock
+ "Set a translation and clipping rectangle only during the execution of aBlock."
+ | tempCanvas |
+ tempCanvas := self copyOffset: delta clipRect: aRectangle.
+ aBlock value: tempCanvas.
+ foundMorph := tempCanvas foundMorph.!
Item was added:
+ ----- Method: ColorPatchCanvas>>translateBy:during: (in category 'drawing-support') -----
+ translateBy: delta during: aBlock
+ "Set a translation only during the execution of aBlock."
+ | tempCanvas |
+ tempCanvas := self copyOffset: delta.
+ aBlock value: tempCanvas.
+ foundMorph := tempCanvas foundMorph.!
Item was added:
+ ----- Method: ColorPatchCanvas>>translateTo:clippingTo:during: (in category 'drawing-support') -----
+ translateTo: newOrigin clippingTo: aRectangle during: aBlock
+ "Set a new origin and clipping rectangle only during the execution of aBlock."
+ | tempCanvas |
+ tempCanvas := self copyOrigin: newOrigin clipRect: aRectangle.
+ aBlock value: tempCanvas.
+ foundMorph := tempCanvas foundMorph.!
Item was added:
+ SketchMorph subclass: #ColorPickerMorph
+ instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency'
+ classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransText TransparentBox'
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !ColorPickerMorph commentStamp: 'kfr 10/27/2003 16:16' prior: 0!
+ A gui for setting color and transparency. Behaviour can be changed with the Preference modalColorPickers.!
Item was added:
+ ----- Method: ColorPickerMorph class>>colorPaletteForDepth:extent: (in category 'class initialization') -----
+ colorPaletteForDepth: depth extent: chartExtent
+ "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
+ "Note: It is slow to build this palette, so it should be cached for quick access."
+ "(Color colorPaletteForDepth: 16 extent: 190 at 60) display"
+
+ | startHue palette transHt vSteps transCaption grayWidth hSteps y c x |
+ palette := Form extent: chartExtent depth: depth.
+ transCaption := "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString"
+ (Form extent: 34 at 9 depth: 1
+ fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
+ offset: 0 at 0).
+ transHt := transCaption height.
+ palette fillWhite: (0 at 0 extent: palette width at transHt).
+ palette fillBlack: (0 at transHt extent: palette width at 1).
+ transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
+ grayWidth := 10.
+ startHue := 338.0.
+ vSteps := palette height - transHt // 2.
+ hSteps := palette width - grayWidth.
+ x := 0.
+ startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | | basicHue |
+ basicHue := Color h: h asFloat s: 1.0 v: 1.0.
+ y := transHt+1.
+ 0 to: vSteps do: [:n |
+ c := basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
+ palette fill: (x at y extent: 1 at 1) fillColor: c.
+ y := y + 1].
+ 1 to: vSteps do: [:n |
+ c := Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
+ palette fill: (x at y extent: 1 at 1) fillColor: c.
+ y := y + 1].
+ x := x + 1].
+ y := transHt + 1.
+ 1 to: vSteps * 2 do: [:n |
+ c := Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
+ palette fill: (x at y extent: 10 at 1) fillColor: c.
+ y := y + 1].
+ ^ palette
+ !
Item was added:
+ ----- Method: ColorPickerMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "ColorPickerMorph initialize"
+
+ ColorChart := ColorPickerMorph colorPaletteForDepth: 16 extent: 190 at 60.
+ DragBox := (11 at 0) extent: 9 at 8.
+ RevertBox := (ColorChart width - 20)@1 extent: 9 at 8.
+ FeedbackBox := (ColorChart width - 10)@1 extent: 9 at 8.
+ TransparentBox := DragBox topRight corner: RevertBox bottomLeft.
+
+ ColorChart fillBlack: ((DragBox left - 1)@0 extent: 1 at 9).
+ ColorChart fillBlack: ((TransparentBox left)@0 extent: 1 at 9).
+ ColorChart fillBlack: ((FeedbackBox left - 1)@0 extent: 1 at 9).
+ ColorChart fillBlack: ((RevertBox left - 1)@0 extent: 1 at 9).
+ (Form dotOfSize: 5) displayOn: ColorChart at: DragBox center + (0 at 1).
+
+ self localeChanged.!
Item was added:
+ ----- Method: ColorPickerMorph class>>localeChanged (in category 'class initialization') -----
+ localeChanged
+ | formTranslator |
+ formTranslator := NaturalLanguageFormTranslator localeID: Locale current localeID.
+ TransText := formTranslator translate: 'translucent'.
+ TransText
+ ifNil: [TransText := Form
+ extent: 63 @ 8
+ depth: 1
+ fromArray: #(4194306 1024 4194306 1024 15628058 2476592640 4887714 2485462016 1883804850 2486772764 4756618 2485462016 4748474 1939416064 0 0 )
+ offset: 0 @ 0].
+ TransText := ColorForm mappingWhiteToTransparentFrom: TransText!
Item was added:
+ ----- Method: ColorPickerMorph class>>noColorCaption (in category 'class initialization') -----
+ noColorCaption
+ | formTranslator |
+ formTranslator := NaturalLanguageFormTranslator localeID: Locale current localeID.
+ ^ (formTranslator translate: 'no color')
+ ifNil: [Form
+ extent: 34 @ 9
+ depth: 1
+ fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0 )
+ offset: 0 @ 0]
+ !
Item was added:
+ ----- Method: ColorPickerMorph class>>perniciousBorderColor (in category 'as yet unclassified') -----
+ perniciousBorderColor
+ "Answer the color of the border lines of a color picker; this color gets reported as you drag the mouse through from the translucent box to the true color area, for example, and can cause some difficulties in some special cases, so it is faithfully reported here in this hard-coded fashion in order that energetic clients wishing to handle it as special-case it can do so."
+
+ ^ Color r: 0.0 g: 0.0 b: 0.032!
Item was added:
+ ----- Method: ColorPickerMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ deleteOnMouseUp
+ ifTrue: [aCustomMenu add: 'stay up' translated action: #toggleDeleteOnMouseUp]
+ ifFalse: [aCustomMenu add: 'do not stay up' translated action: #toggleDeleteOnMouseUp].
+ updateContinuously
+ ifTrue: [aCustomMenu add: 'update only at end' translated action: #toggleUpdateContinuously]
+ ifFalse: [aCustomMenu add: 'update continuously' translated action: #toggleUpdateContinuously].
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>addToWorld:near: (in category 'other') -----
+ addToWorld: world near: box
+ | goodLocation |
+ goodLocation := self bestPositionNear: box inWorld: world.
+ world allMorphsDo:
+ [:p | (p isMemberOf: ColorPickerMorph) ifTrue:
+ [(p ~~ self and: [p owner notNil and: [p target == target]]) ifTrue:
+ [(p selector == selector and: [p argument == argument])
+ ifTrue: [^ p comeToFront "uncover existing picker"]
+ ifFalse: ["place second picker relative to first"
+ goodLocation := self bestPositionNear: p bounds inWorld: world]]]].
+ self position: goodLocation.
+ world addMorphFront: self.
+ self changed
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>anchorAndRunModeless: (in category 'private') -----
+ anchorAndRunModeless: aHand
+ "If user clicks on the drag-dot of a modal picker,
+ anchor it, and change to modeless operation."
+
+ aHand showTemporaryCursor: nil. "revert to normal cursor"
+ self initializeModal: false; originalColor: originalColor. "reset as modeless"
+ aHand flushEvents. "Drop any events gathered during modal loop"
+ aHand position: Sensor cursorPoint; grabMorph: self. "Slip into drag operation"
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>argument (in category 'accessing') -----
+ argument
+ ^argument!
Item was added:
+ ----- Method: ColorPickerMorph>>argument: (in category 'accessing') -----
+ argument: anObject
+ argument := anObject!
Item was added:
+ ----- Method: ColorPickerMorph>>argumentsWith: (in category 'private') -----
+ argumentsWith: aColor
+ "Return an argument array appropriate to this action selector"
+
+ | nArgs |
+ nArgs := selector ifNil:[0] ifNotNil:[selector numArgs].
+ nArgs = 0 ifTrue:[^#()].
+ nArgs = 1 ifTrue:[^ {aColor}].
+ nArgs = 2 ifTrue:[^ {aColor. sourceHand}].
+ nArgs = 3 ifTrue:[^ {aColor. argument. sourceHand}].
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>bestPositionNear:inWorld: (in category 'other') -----
+ bestPositionNear: box inWorld: world
+ | points b |
+ points := #(topCenter rightCenter bottomCenter leftCenter). "possible anchors"
+ 1 to: 4 do:
+ [:i | "Try the four obvious anchor points"
+ b := self bounds align: (self bounds perform: (points at: i))
+ with: (box perform: (points atWrap: i + 2)).
+ (world viewBox containsRect: b) ifTrue:
+ [^ b topLeft" Yes, it fits"]].
+
+ ^ 20 at 20 "when all else fails"
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>buildChartForm (in category 'initialization') -----
+ buildChartForm
+ | chartForm |
+ chartForm := ColorChart deepCopy asFormOfDepth: Display depth.
+ chartForm fill: ((TransparentBox left + 9)@0 extent: 1 at 9) fillColor: Color lightGray.
+ chartForm fill: ((TransparentBox right - 10)@0 extent: 1 at 9) fillColor: Color lightGray.
+ TransText displayOn: chartForm at: 62 at 0.
+ Display depth = 32 ifTrue:
+ ["Set opaque bits for 32-bit display"
+ chartForm fill: chartForm boundingBox rule: Form under
+ fillColor: (Color r: 0.0 g: 0.0 b: 0.0 alpha: 1.0)].
+ chartForm borderWidth: 1.
+ self form: chartForm.
+ selectedColor ifNotNil: [self updateAlpha: selectedColor alpha].
+ self updateSelectorDisplay.
+
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>choseModalityFromPreference (in category 'initialization') -----
+ choseModalityFromPreference
+ "Decide whether to be modal or not by consulting the prevailing preference"
+
+ self initializeModal: Preferences modalColorPickers!
Item was added:
+ ----- Method: ColorPickerMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+ ^ (super containsPoint: aPoint)
+ or: [RevertBox containsPoint: aPoint - self topLeft]!
Item was added:
+ ----- Method: ColorPickerMorph>>delete (in category 'submorphs-add/remove') -----
+ delete
+ "The moment of departure has come.
+ If the receiver has an affiliated command, finalize it and have the system remember it.
+ In any case, delete the receiver"
+
+ (selector isNil or: [ target isNil ]) ifFalse: [
+ self rememberCommand:
+ (Command new
+ cmdWording: 'color change' translated;
+ undoTarget: target selector: selector arguments: (self argumentsWith: originalColor);
+ redoTarget: target selector: selector arguments: (self argumentsWith: selectedColor)).
+ ].
+ super delete!
Item was added:
+ ----- Method: ColorPickerMorph>>deleteAllBalloons (in category 'private') -----
+ deleteAllBalloons
+
+ self submorphsDo: [:m | m deleteBalloon].
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>deleteOnMouseUp (in category 'accessing') -----
+ deleteOnMouseUp
+
+ ^ deleteOnMouseUp
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>deleteOnMouseUp: (in category 'accessing') -----
+ deleteOnMouseUp: aBoolean
+
+ deleteOnMouseUp := aBoolean.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ aCanvas depth = 1 ifTrue: [aCanvas fillRectangle: self bounds color: Color white].
+ Display depth = originalForm depth ifFalse: [self buildChartForm].
+ super drawOn: aCanvas!
Item was added:
+ ----- Method: ColorPickerMorph>>getColorFromKedamaWorldIfPossible: (in category 'kedama') -----
+ getColorFromKedamaWorldIfPossible: aGlobalPoint
+
+ self world submorphs do: [:sub |
+ (sub isKedamaMorph) ifTrue: [
+ sub morphsAt: aGlobalPoint unlocked: false do: [:e |
+ ^ e colorAt: (aGlobalPoint - e topLeft).
+ ].
+ ].
+ ].
+ ^ nil.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ true
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>indicateColorUnderMouse (in category 'other') -----
+ indicateColorUnderMouse
+ "Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color."
+
+ | pt |
+ self pickColorAt: (pt := Sensor cursorPoint).
+ isModal ifTrue:
+ [self activeHand position: pt.
+ self world displayWorldSafely; runStepMethods].
+ ^ selectedColor !
Item was added:
+ ----- Method: ColorPickerMorph>>inhibitDragging (in category 'event handling') -----
+ inhibitDragging
+
+ ^self hasProperty: #noDraggingThisPicker!
Item was added:
+ ----- Method: ColorPickerMorph>>initialize (in category 'initialization') -----
+ initialize
+ "Initialize the receiver. Obey the modalColorPickers preference when deciding how to configure myself. This is not quite satisfactory -- we'd like to have explicit calls tell us things like whether whether to be modal, whether to allow transparency, but for the moment, in grand Morphic fashion, this is rather inflexibly all housed right here"
+
+ super initialize.
+ self clipSubmorphs: true.
+ self buildChartForm.
+
+ selectedColor := Color white.
+ sourceHand := nil.
+ deleteOnMouseUp := false.
+ clickedTranslucency := false.
+ updateContinuously := true.
+ selector := nil.
+ target := nil!
Item was added:
+ ----- Method: ColorPickerMorph>>initializeForPropertiesPanel (in category 'initialization') -----
+ initializeForPropertiesPanel
+ "Initialize the receiver. If beModal is true, it will be a modal color picker, else not"
+
+ isModal := false.
+ self removeAllMorphs.
+ self setProperty: #noDraggingThisPicker toValue: true.
+
+ self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft))
+ color: Color transparent; setCenteredBalloonText: 'restore original color' translated).
+ self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft))
+ color: Color transparent; setCenteredBalloonText: 'shows selected color' translated).
+ self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft))
+ color: Color transparent; setCenteredBalloonText: 'adjust translucency' translated).
+
+ self buildChartForm.
+
+ selectedColor ifNil: [selectedColor := Color white].
+ sourceHand := nil.
+ deleteOnMouseUp := false.
+ updateContinuously := true.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>initializeModal: (in category 'initialization') -----
+ initializeModal: beModal
+ "Initialize the receiver. If beModal is true, it will be a modal color picker, else not"
+
+ isModal := beModal.
+ self removeAllMorphs.
+ isModal ifFalse:
+ [theSelectorDisplayMorph := AlignmentMorph newRow
+ color: Color white;
+ borderWidth: 1;
+ borderColor: Color red;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ addMorph: (StringMorph contents: 'theSelector' translated).
+ self addMorph: theSelectorDisplayMorph.
+
+ self addMorph: (SimpleButtonMorph new borderWidth: 0;
+ label: 'x' font: nil; color: Color transparent;
+ actionSelector: #delete; target: self; useSquareCorners;
+ position: self topLeft - (0 at 3); extent: 10 at 12;
+ setCenteredBalloonText: 'dismiss color picker' translated)].
+
+ self addMorph: ((Morph newBounds: (DragBox translateBy: self topLeft))
+ color: Color transparent; setCenteredBalloonText: 'put me somewhere' translated).
+ self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft))
+ color: Color transparent; setCenteredBalloonText: 'restore original color' translated).
+ self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft))
+ color: Color transparent; setCenteredBalloonText: 'shows selected color' translated).
+ self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft))
+ color: Color transparent; setCenteredBalloonText: 'adjust translucency' translated).
+
+ self buildChartForm.
+
+ selectedColor ifNil: [selectedColor := Color white].
+ sourceHand := nil.
+ deleteOnMouseUp := false.
+ updateContinuously := true.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>isLikelyRecipientForMouseOverHalos (in category 'halos and balloon help') -----
+ isLikelyRecipientForMouseOverHalos
+ ^ false!
Item was added:
+ ----- Method: ColorPickerMorph>>locationIndicator (in category 'accessing') -----
+ locationIndicator
+
+ ^self valueOfProperty: #locationIndicator ifAbsent:[ | loc |
+ loc := EllipseMorph new.
+ loc color: Color transparent;
+ borderWidth: 1;
+ borderColor: Color red;
+ extent: 6 at 6.
+ self setProperty: #locationIndicator toValue: loc.
+ self addMorphFront: loc.
+ loc]!
Item was added:
+ ----- Method: ColorPickerMorph>>modalBalloonHelpAtPoint: (in category 'private') -----
+ modalBalloonHelpAtPoint: cursorPoint
+ self flag: #arNote. "Throw this away. There needs to be another way."
+ self submorphsDo:
+ [:m |
+ m wantsBalloon
+ ifTrue:
+ [(m valueOfProperty: #balloon) isNil
+ ifTrue:
+ [(m containsPoint: cursorPoint) ifTrue: [m showBalloon: m balloonText]]
+ ifFalse: [(m containsPoint: cursorPoint) ifFalse: [m deleteBalloon]]]]!
Item was added:
+ ----- Method: ColorPickerMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ | localPt |
+ localPt := evt cursorPoint - self topLeft.
+ self deleteAllBalloons.
+ clickedTranslucency := TransparentBox containsPoint: localPt.
+ self inhibitDragging ifFalse: [
+ (DragBox containsPoint: localPt)
+ ifTrue: [^ evt hand grabMorph: self].
+ ].
+ (RevertBox containsPoint: localPt)
+ ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].
+ self inhibitDragging ifFalse: [self comeToFront].
+ sourceHand := evt hand.
+ self startStepping.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+
+ | c |
+ self stopStepping.
+ sourceHand := nil.
+ deleteOnMouseUp ifTrue: [self delete].
+ c := self getColorFromKedamaWorldIfPossible: evt cursorPoint.
+ c ifNotNil: [selectedColor := c].
+ self updateTargetColor.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>originalColor: (in category 'accessing') -----
+ originalColor: colorOrSymbol
+ "Set the receiver's original color. It is at this point that a command is launched to represent the action of the picker, in support of Undo."
+
+ originalColor := (colorOrSymbol isColor)
+ ifTrue: [colorOrSymbol]
+ ifFalse: [Color lightGreen].
+ originalForm fill: RevertBox fillColor: originalColor.
+ selectedColor := originalColor.
+ self updateAlpha: originalColor alpha.
+ self locationIndicator
+ center: self topLeft + (self positionOfColor: originalColor)!
Item was added:
+ ----- Method: ColorPickerMorph>>pickColorAt: (in category 'private') -----
+ pickColorAt: aGlobalPoint
+
+ | alpha selfRelativePoint pickedColor c |
+ clickedTranslucency ifNil: [clickedTranslucency := false].
+ selfRelativePoint := (self globalPointToLocal: aGlobalPoint) - self topLeft.
+ (FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self].
+ (RevertBox containsPoint: selfRelativePoint)
+ ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].
+
+ "check for transparent color and update using appropriate feedback color "
+ (TransparentBox containsPoint: selfRelativePoint) ifTrue:
+ [clickedTranslucency ifFalse: [^ self]. "Can't wander into translucency control"
+ alpha := (selfRelativePoint x - TransparentBox left - 10) asFloat /
+ (TransparentBox width - 20)
+ min: 1.0 max: 0.0.
+ "(alpha roundTo: 0.01) printString , ' ' displayAt: 0 at 0." " -- debug"
+ self
+ updateColor: (selectedColor alpha: alpha)
+ feedbackColor: (selectedColor alpha: alpha).
+ ^ self].
+
+ "pick up color, either inside or outside this world"
+ clickedTranslucency ifTrue: [^ self]. "Can't wander out of translucency control"
+ self locationIndicator visible: false. self refreshWorld.
+ pickedColor := Display colorAt: aGlobalPoint.
+ c := self getColorFromKedamaWorldIfPossible: aGlobalPoint.
+ c ifNotNil: [pickedColor := c].
+ self locationIndicator visible: true. self refreshWorld.
+ self
+ updateColor: (
+ (selectedColor isColor and: [selectedColor isTranslucentColor])
+ ifTrue: [pickedColor alpha: selectedColor alpha]
+ ifFalse: [pickedColor]
+ )
+ feedbackColor: pickedColor!
Item was added:
+ ----- Method: ColorPickerMorph>>pickUpColorFor: (in category 'menu') -----
+ pickUpColorFor: aMorph
+ "Show the eyedropper cursor, and modally track the mouse through a mouse-down and mouse-up cycle"
+
+ | aHand localPt c |
+ aHand := aMorph ifNil: [self activeHand] ifNotNil: [aMorph activeHand].
+ aHand ifNil: [aHand := self currentHand].
+ self addToWorld: aHand world near: (aMorph ifNil: [aHand world]) fullBounds.
+ self owner ifNil: [^ self].
+
+ aHand showTemporaryCursor: (ScriptingSystem formAtKey: #Eyedropper)
+ hotSpotOffset: 6 negated @ 4 negated. "<<<< the form was changed a bit??"
+
+ self updateContinuously: false.
+ [Sensor anyButtonPressed]
+ whileFalse:
+ [self trackColorUnderMouse].
+ self deleteAllBalloons.
+
+ localPt := Sensor cursorPoint - self topLeft.
+ self inhibitDragging ifFalse: [
+ (DragBox containsPoint: localPt) ifTrue:
+ ["Click or drag the drag-dot means to anchor as a modeless picker"
+ ^ self anchorAndRunModeless: aHand].
+ ].
+ (clickedTranslucency := TransparentBox containsPoint: localPt)
+ ifTrue: [selectedColor := originalColor].
+
+ self updateContinuously: true.
+ [Sensor anyButtonPressed]
+ whileTrue:
+ [self updateTargetColorWith: self indicateColorUnderMouse].
+ c := self getColorFromKedamaWorldIfPossible: Sensor cursorPoint.
+ c ifNotNil: [selectedColor := c].
+ aHand newMouseFocus: nil;
+ showTemporaryCursor: nil;
+ flushEvents.
+ self delete.
+
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>positionOfColor: (in category 'private') -----
+ positionOfColor: aColor
+ "Compute the position of the given color in the color chart form"
+ | rgbRect x y h s v |
+ rgbRect := (0 at 0 extent: originalForm boundingBox extent) insetBy: (1 at 10 corner: 11 at 1).
+ h := aColor hue.
+ s := aColor saturation.
+ v := aColor brightness.
+ h = 0.0 ifTrue:["gray"
+ ^(rgbRect right + 6) @ (rgbRect height * (1.0 - v) + rgbRect top)].
+ x := (h + 22 \\ 360 / 360.0 * rgbRect width) rounded.
+ y := 0.5.
+ s < 1.0 ifTrue:[y := y - (1.0 - s * 0.5)].
+ v < 1.0 ifTrue:[y := y + (1.0 - v * 0.5)].
+ y := (y * rgbRect height) rounded.
+ ^x at y + (1 at 10)!
Item was added:
+ ----- Method: ColorPickerMorph>>putUpFor:near: (in category 'other') -----
+ putUpFor: aMorph near: aRectangle
+ "Put the receiver up on the screen. Note highly variant behavior depending on the setting of the #modalColorPickers preference"
+ | layerNumber |
+ aMorph isMorph ifTrue: [
+ layerNumber := aMorph morphicLayerNumber.
+ aMorph allOwnersDo:[:m|
+ layerNumber := layerNumber min: m morphicLayerNumber].
+ self setProperty: #morphicLayerNumber toValue: layerNumber - 0.1
+ ].
+
+ isModal == true "backward compatibility"
+ ifTrue:
+ [self pickUpColorFor: aMorph]
+ ifFalse:
+ [self addToWorld:
+ ((aMorph notNil and: [aMorph world notNil])
+ ifTrue:
+ [aMorph world]
+ ifFalse:
+ [self currentWorld])
+ near:
+ (aRectangle ifNil:
+ [aMorph ifNil: [100 at 100 extent: 1 at 1] ifNotNil: [aMorph fullBoundsInWorld]])]!
Item was added:
+ ----- Method: ColorPickerMorph>>selectedColor (in category 'accessing') -----
+ selectedColor
+
+ ^ selectedColor
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>selector (in category 'accessing') -----
+ selector
+
+ ^ selector
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>selector: (in category 'accessing') -----
+ selector: aSymbol
+ "Set the selector to be associated with the receiver. Store it in the receiver's command, if appropriate"
+
+ selector := aSymbol.
+ self updateSelectorDisplay!
Item was added:
+ ----- Method: ColorPickerMorph>>sourceHand (in category 'accessing') -----
+ sourceHand
+
+ ^ sourceHand
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>sourceHand: (in category 'accessing') -----
+ sourceHand: aHand
+
+ sourceHand := aHand.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>step (in category 'stepping and presenter') -----
+ step
+
+ sourceHand ifNotNil:
+ [self pickColorAt: sourceHand position].
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ 50
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>target (in category 'accessing') -----
+ target
+
+ ^ target
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>target: (in category 'accessing') -----
+ target: anObject
+ target := anObject.
+ selectedColor := (target respondsTo: #color)
+ ifTrue: [target color]
+ ifFalse: [Color white]!
Item was added:
+ ----- Method: ColorPickerMorph>>toggleDeleteOnMouseUp (in category 'menu') -----
+ toggleDeleteOnMouseUp
+
+ deleteOnMouseUp := deleteOnMouseUp not.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>toggleUpdateContinuously (in category 'menu') -----
+ toggleUpdateContinuously
+
+ updateContinuously := updateContinuously not.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>trackColorAt: (in category 'private') -----
+ trackColorAt: aGlobalPoint
+ "Before the mouse comes down in a modal color picker, track the color under the cursor, and show it in the feedback box, but do not make transparency changes"
+
+ | selfRelativePoint pickedColor |
+ selfRelativePoint := (self globalPointToLocal: aGlobalPoint) - self topLeft.
+ (FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self].
+ (RevertBox containsPoint: selfRelativePoint)
+ ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].
+
+ "check for transparent color and update using appropriate feedback color "
+ (TransparentBox containsPoint: selfRelativePoint) ifTrue: [^ self].
+
+ "pick up color, either inside or outside this world"
+ pickedColor := Display colorAt: aGlobalPoint.
+ self updateColor: (pickedColor alpha: originalColor alpha)
+ feedbackColor: pickedColor!
Item was added:
+ ----- Method: ColorPickerMorph>>trackColorUnderMouse (in category 'other') -----
+ trackColorUnderMouse
+ "Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color."
+
+ | pt |
+ selectedColor := originalColor.
+ self trackColorAt: (pt := Sensor cursorPoint).
+ isModal ifTrue:
+ [self activeHand position: pt.
+ self world displayWorldSafely; runStepMethods.
+ self modalBalloonHelpAtPoint: pt].
+ ^ selectedColor !
Item was added:
+ ----- Method: ColorPickerMorph>>updateAlpha: (in category 'private') -----
+ updateAlpha: alpha
+ | sliderRect |
+ sliderRect := (TransparentBox left + 10)@1 corner: (TransparentBox right - 9)@9.
+ originalForm fill: (sliderRect withRight: sliderRect left + (alpha*sliderRect width))
+ fillColor: Color lightGray.
+ originalForm fillWhite: (sliderRect withLeft: sliderRect left + (alpha*sliderRect width)).
+ originalForm fill: ((TransparentBox right - 9)@1 extent: 8 at 8)
+ fillColor: (alpha < 1.0 ifTrue: [Color white] ifFalse: [Color lightGray]).
+ TransText displayOn: originalForm at: 62 at 1 rule: Form paint.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>updateColor:feedbackColor: (in category 'private') -----
+ updateColor: aColor feedbackColor: feedbackColor
+ "Set my selected color to the given color if it is different. Give user feedback. Inform the target of the change if the target and selector are not nil."
+
+ selectedColor = aColor ifTrue: [^ self]. "do nothing if color doesn't change"
+
+ self updateAlpha: aColor alpha.
+ originalForm fill: FeedbackBox fillColor: feedbackColor.
+ self form: originalForm.
+ selectedColor := aColor.
+ updateContinuously ifTrue: [self updateTargetColor].
+ self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).!
Item was added:
+ ----- Method: ColorPickerMorph>>updateContinuously (in category 'accessing') -----
+ updateContinuously
+
+ ^ updateContinuously
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>updateContinuously: (in category 'accessing') -----
+ updateContinuously: aBoolean
+
+ updateContinuously := aBoolean.
+ !
Item was added:
+ ----- Method: ColorPickerMorph>>updateSelectorDisplay (in category 'initialization') -----
+ updateSelectorDisplay
+ theSelectorDisplayMorph ifNil: [^self].
+ theSelectorDisplayMorph position: self bottomLeft.
+ theSelectorDisplayMorph firstSubmorph contents: selector asString , ' ' , selectedColor printString!
Item was added:
+ ----- Method: ColorPickerMorph>>updateTargetColor (in category 'private') -----
+ updateTargetColor
+ | nArgs |
+ (target notNil and: [selector notNil])
+ ifTrue:
+ [self updateSelectorDisplay.
+ nArgs := selector numArgs.
+ nArgs = 1 ifTrue: [^target perform: selector with: selectedColor].
+ nArgs = 2
+ ifTrue:
+ [^target
+ perform: selector
+ with: selectedColor
+ with: sourceHand].
+ nArgs = 3
+ ifTrue:
+ [^target
+ perform: selector
+ with: selectedColor
+ with: argument
+ with: sourceHand]]!
Item was added:
+ ----- Method: ColorPickerMorph>>updateTargetColorWith: (in category 'private') -----
+ updateTargetColorWith: aColor
+ "Update the target so that it reflects aColor as the color choice"
+
+ (target notNil and: [selector notNil])
+ ifTrue:
+ [self updateSelectorDisplay.
+ ^target perform: selector withArguments: (self argumentsWith: aColor)]!
Item was added:
+ MorphicModel subclass: #ColorPresenterMorph
+ instanceVariableNames: 'contentMorph labelMorph solidLabelMorph getColorSelector'
+ classVariableNames: 'HatchForm'
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !ColorPresenterMorph commentStamp: 'gvc 5/18/2007 13:38' prior: 0!
+ Displays a colour with alpha against a white, hatched and black background.!
Item was added:
+ ----- Method: ColorPresenterMorph class>>hatchForm (in category 'graphics constants') -----
+ hatchForm
+ "Answer a form showing a grid hatch pattern."
+
+ ^HatchForm ifNil: [HatchForm := self newHatchForm]!
Item was added:
+ ----- Method: ColorPresenterMorph class>>newHatchForm (in category 'graphics constants') -----
+ newHatchForm
+ "Answer a new hatch form."
+
+ ^(Form
+ extent: 8 at 8
+ depth: 1
+ fromArray: #( 4026531840 4026531840 4026531840 4026531840 251658240 251658240 251658240 251658240)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: ColorPresenterMorph class>>on:color: (in category 'instance creation') -----
+ on: anObject color: getSel
+ "Answer a new instance of the receiver on the given model using
+ the given selectors as the interface."
+
+ "(ColorPresenterMorph on: (BorderedMorph new) color: #color) openInWorld"
+
+ ^self new
+ on: anObject
+ color: getSel!
Item was added:
+ ----- Method: ColorPresenterMorph>>contentMorph (in category 'accessing') -----
+ contentMorph
+ "The outer, containing Morph."
+ ^ contentMorph!
Item was added:
+ ----- Method: ColorPresenterMorph>>contentMorph: (in category 'accessing') -----
+ contentMorph: aMorph
+ "The outer, containing Morph."
+ contentMorph := aMorph!
Item was added:
+ ----- Method: ColorPresenterMorph>>getColorSelector (in category 'accessing') -----
+ getColorSelector
+ "The selector symbol used to retrieve the color from my model."
+ ^ getColorSelector!
Item was added:
+ ----- Method: ColorPresenterMorph>>getColorSelector: (in category 'accessing') -----
+ getColorSelector: aSymbol
+ "The selector symbol used to retrieve the color from my model."
+ getColorSelector := aSymbol!
Item was added:
+ ----- Method: ColorPresenterMorph>>initialize (in category 'initializing') -----
+ initialize
+ "Initialize the receiver."
+
+ super initialize.
+ self
+ borderWidth: 0;
+ changeTableLayout;
+ labelMorph: self newLabelMorph;
+ solidLabelMorph: self newLabelMorph;
+ contentMorph: self newContentMorph;
+ addMorphBack: self contentMorph!
Item was added:
+ ----- Method: ColorPresenterMorph>>labelMorph (in category 'accessing') -----
+ labelMorph
+ "The morph that renders the actual color being presented."
+ ^ labelMorph!
Item was added:
+ ----- Method: ColorPresenterMorph>>labelMorph: (in category 'accessing') -----
+ labelMorph: aMorph
+ "The morph that renders the actual color being presented."
+ labelMorph := aMorph!
Item was added:
+ ----- Method: ColorPresenterMorph>>newContentMorph (in category 'initializing') -----
+ newContentMorph
+ "Answer a new content morph"
+
+ ^Morph new
+ color: Color transparent;
+ changeTableLayout;
+ borderStyle: (BorderStyle inset width: 1);
+ vResizing: #spaceFill;
+ hResizing: #spaceFill;
+ addMorph: self newHatchMorph;
+ yourself!
Item was added:
+ ----- Method: ColorPresenterMorph>>newHatchMorph (in category 'initializing') -----
+ newHatchMorph
+ "Answer a new morph showing the three backgrounds; white, hatch pattern, and black, against which my labelMorph is displayed."
+ ^ Morph new
+ color: Color transparent ;
+ changeProportionalLayout ;
+ vResizing: #spaceFill ;
+ hResizing: #spaceFill ;
+ minWidth: 48 ;
+ minHeight: 12 ;
+
+ addMorph: (Morph new color: Color white)
+ fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 0.3 @ 1)) ;
+
+ addMorph: (Morph new fillStyle: (InfiniteForm with: self class hatchForm))
+ fullFrame: (LayoutFrame fractions: (0.3 @ 0 corner: 0.7 @ 1)) ;
+
+ addMorph: self solidLabelMorph
+ fullFrame: (LayoutFrame fractions: (0.7 @ 0 corner: 1 @ 1)) ;
+
+ addMorph: self labelMorph
+ fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1))!
Item was added:
+ ----- Method: ColorPresenterMorph>>newLabelMorph (in category 'initializing') -----
+ newLabelMorph
+ "Answer a new label morph"
+
+ ^Morph new!
Item was added:
+ ----- Method: ColorPresenterMorph>>on:color: (in category 'initializing') -----
+ on: anObject color: getColSel
+ "Set the receiver to the given model parameterized by the given message selectors."
+
+ self
+ model: anObject;
+ getColorSelector: getColSel;
+ updateColor!
Item was added:
+ ----- Method: ColorPresenterMorph>>setColor: (in category 'initializing') -----
+ setColor: aColor
+ "Update the colour of the labels."
+
+ self labelMorph color: aColor.
+ self solidLabelMorph color: aColor asNontranslucentColor!
Item was added:
+ ----- Method: ColorPresenterMorph>>solidLabelMorph (in category 'accessing') -----
+ solidLabelMorph
+ "Answer the value of solidLabelMorph"
+
+ ^ solidLabelMorph!
Item was added:
+ ----- Method: ColorPresenterMorph>>solidLabelMorph: (in category 'accessing') -----
+ solidLabelMorph: anObject
+ "Set the value of solidLabelMorph"
+
+ solidLabelMorph := anObject!
Item was added:
+ ----- Method: ColorPresenterMorph>>update: (in category 'initializing') -----
+ update: aSymbol
+ "Refer to the comment in View|update:."
+
+ aSymbol == self getColorSelector ifTrue:
+ [self updateColor.
+ ^ self]!
Item was added:
+ ----- Method: ColorPresenterMorph>>updateColor (in category 'initializing') -----
+ updateColor
+ "Update the color state."
+
+ |col|
+ self getColorSelector ifNotNil: [
+ col := (self model perform: self getColorSelector) ifNil: [Color transparent].
+ self setColor: col]!
Item was added:
+ ----- Method: CompiledMethod>>explorerContents (in category '*Morphic-Explorer') -----
+ explorerContents
+ "(CompiledMethod compiledMethodAt: #explorerContents) explore"
+
+ ^Array streamContents:
+ [:s| | tokens |
+ tokens := Scanner new scanTokens: (self headerDescription readStream skipTo: $"; upTo: $").
+ s nextPut: (ObjectExplorerWrapper
+ with: ((0 to: tokens size by: 2) collect:
+ [:i| i = 0 ifTrue: [self header] ifFalse: [{tokens at: i - 1. tokens at: i}]])
+ name: 'header'
+ model: self).
+ (1 to: self numLiterals) do:
+ [:key|
+ s nextPut: (ObjectExplorerWrapper
+ with: (self literalAt: key)
+ name: ('literal', key printString contractTo: 32)
+ model: self)].
+ self isQuick
+ ifTrue: [s nextPut: (ObjectExplorerWrapper
+ with: self symbolic
+ name: #symbolic
+ model: self)]
+ ifFalse:
+ [self symbolicLinesDo:
+ [:pc :line|
+ pc <= 1
+ ifTrue:
+ [s nextPut: (ObjectExplorerWrapper
+ with: line
+ name: 'pragma'
+ model: self)]
+ ifFalse:
+ [s nextPut: (ObjectExplorerWrapper
+ with: line
+ name: pc printString
+ model: self)]]].
+ "should be self numLiterals + 1 * Smalltalk wordSize + 1"
+ self endPC + 1
+ to: self basicSize
+ do: [:key|
+ s nextPut: (ObjectExplorerWrapper
+ with: (self basicAt: key)
+ name: key printString
+ model: self)]]!
Item was added:
+ SimpleBorder subclass: #ComplexBorder
+ instanceVariableNames: 'style colors lineStyles'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Borders'!
+
+ !ComplexBorder commentStamp: 'nice 3/24/2010 07:36' prior: 0!
+ see BorderedMorph.
+
+ poly := polygon250
+
+ baseColor := Color blue twiceLighter.
+ border := (ComplexBorder framed: 10) baseColor: poly color.
+ border frameRectangle: ((100 at 100 extent: 200 at 200) insetBy: -5) on: Display getCanvas.
+ baseColor := Color red twiceLighter.
+ border := (ComplexBorder framed: 10) baseColor: baseColor.
+ border drawPolygon: {100 at 100. 300 at 100. 300 at 300. 100 at 300} on: Display getCanvas.
+
+ border drawPolyPatchFrom: 100 at 200 via: 100 at 100 via: 200 at 100 to: 200 at 200 on: Display getCanvas.
+ border drawPolyPatchFrom: 100 at 100 via: 200 at 100 via: 200 at 200 to: 100 at 200 on: Display getCanvas.
+ border drawPolyPatchFrom: 200 at 100 via: 200 at 200 via: 100 at 200 to: 100 at 100 on: Display getCanvas.
+ border drawPolyPatchFrom: 200 at 200 via: 100 at 200 via: 100 at 100 to: 200 at 100 on: Display getCanvas.
+
+ border := (ComplexBorder raised: 10) baseColor: poly color.
+ border drawPolygon: poly getVertices on: Display getCanvas
+
+ 360 / 16.0 22.5
+ points := (0 to: 15) collect:[:i| (Point r: 100 degrees: i*22.5) + 200].
+ Display getCanvas fillOval: (100 at 100 extent: 200 at 200) color: baseColor.
+ border drawPolygon: points on: Display getCanvas.
+
+ -1 to: points size + 1 do:[:i|
+ border drawPolyPatchFrom: (points atWrap: i) via: (points atWrap: i+1) via: (points atWrap: i+2) to: (points atWrap: i+3) on: Display getCanvas.
+ ].
+
+ Display getCanvas fillOval: (100 at 100 extent: 200 at 200) color: baseColor.
+ 0 to: 36 do:[:i|
+ border drawLineFrom: (Point r: 100 degrees: i*10) + 200 to: (Point r: 100 degrees: i+1*10) + 200
+ on: Display getCanvas.
+ ].
+ drawPolygon:
+ Point r: 1.0 degrees: 10
+ MessageTally spyOn:[
+ Display deferUpdates: true.
+ t1 := [1 to: 1000 do:[:i|
+ border drawLineFrom: (100 at 100) to: (300 at 100) on: Display getCanvas.
+ border drawLineFrom: (300 at 100) to: (300 at 300) on: Display getCanvas.
+ border drawLineFrom: (300 at 300) to: (100 at 300) on: Display getCanvas.
+ border drawLineFrom: (100 at 300) to: (100 at 100) on: Display getCanvas]] timeToRun.
+ Display deferUpdates: false.
+ ].
+
+ MessageTally spyOn:[
+ Display deferUpdates: true.
+ t2 := [1 to: 1000 do:[:i|
+ border drawLine2From: (100 at 100) to: (300 at 100) on: Display getCanvas.
+ border drawLine2From: (300 at 100) to: (300 at 300) on: Display getCanvas.
+ border drawLine2From: (300 at 300) to: (100 at 300) on: Display getCanvas.
+ border drawLine2From: (100 at 300) to: (100 at 100) on: Display getCanvas]] timeToRun.
+ Display deferUpdates: false.
+ ].
+
+ !
Item was added:
+ ----- Method: ComplexBorder class>>style: (in category 'instance creation') -----
+ style: aSymbol
+ ^self new style: aSymbol!
Item was added:
+ ----- Method: ComplexBorder>>colors (in category 'accessing') -----
+ colors
+ ^colors ifNil:[colors := self computeColors].!
Item was added:
+ ----- Method: ComplexBorder>>colorsForDirection: (in category 'private') -----
+ colorsForDirection: direction
+ "Return an array of colors describing the receiver in the given direction"
+
+ | colorArray dT cc |
+ cc := self colors.
+ direction x * direction y <= 0
+ ifTrue:
+ ["within up->right or down->left transition; no color blend needed"
+
+ colorArray := (direction x > 0 or: [direction y < 0])
+ ifTrue:
+ ["up->right"
+ cc copyFrom: 1 to: width]
+ ifFalse:
+ ["down->left"
+ "colors are stored in reverse direction when following a line"
+ (cc copyFrom: width + 1 to: cc size) reversed]]
+ ifFalse:
+ ["right->down or left->up transition; need color blend"
+
+ colorArray := Array new: width.
+ dT := direction x asFloat / (direction x + direction y).
+ (direction x > 0 or: [direction y >= 0])
+ ifTrue:
+ ["top-right"
+
+ 1 to: width
+ do:
+ [:i |
+ colorArray at: i put: ((cc at: i) mixed: dT with: (cc at: cc size - i + 1))]]
+ ifFalse:
+ ["bottom-left"
+
+ 1 to: width
+ do:
+ [:i |
+ colorArray at: i put: ((cc at: cc size - i + 1) mixed: dT with: (cc at: i))]]].
+ ^colorArray!
Item was added:
+ ----- Method: ComplexBorder>>computeAltFramedColors (in category 'private') -----
+ computeAltFramedColors
+ | base light dark w hw colorArray param |
+ base := self color asColor.
+ light := Color white.
+ dark := Color black.
+ w := self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width].
+ w := w asInteger.
+ w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}].
+ colorArray := Array new: w.
+ hw := w // 2.
+ "brighten"
+ 0 to: hw-1 do:[:i|
+ param := 0.5 + (i asFloat / hw * 0.5).
+ colorArray at: i+1 put: (base mixed: param with: dark). "brighten"
+ colorArray at: w-i put: (base mixed: param with: light). "darken"
+ ].
+ w odd ifTrue:[colorArray at: hw+1 put: base].
+ ^colorArray, colorArray!
Item was added:
+ ----- Method: ComplexBorder>>computeAltInsetColors (in category 'private') -----
+ computeAltInsetColors
+ | base light dark w colorArray param hw |
+ base := self color asColor.
+ light := Color white.
+ dark := Color black.
+ w := self width isPoint
+ ifTrue: [self width x max: self width y]
+ ifFalse: [self width].
+ w := w asInteger.
+ colorArray := Array new: w * 2.
+ hw := 0.5 / w.
+ 0 to: w - 1
+ do:
+ [:i |
+ param := false
+ ifTrue:
+ ["whats this ???!! false ifTrue:[]"
+
+ 0.5 + (hw * i)]
+ ifFalse: [0.5 + (hw * (w - i))].
+ colorArray at: i + 1 put: (base mixed: param with: dark). "darken"
+ colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"].
+ ^colorArray!
Item was added:
+ ----- Method: ComplexBorder>>computeAltRaisedColors (in category 'private') -----
+ computeAltRaisedColors
+ | base light dark w colorArray param hw |
+ base := self color asColor.
+ light := Color white.
+ dark := Color black.
+ w := self width isPoint
+ ifTrue: [self width x max: self width y]
+ ifFalse: [self width].
+ w := w asInteger.
+ colorArray := Array new: w * 2.
+ hw := 0.5 / w.
+ 0 to: w - 1
+ do:
+ [:i | "again !! false ifTrue:[] ?!!"
+ param := false ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))].
+ colorArray at: i + 1 put: (base mixed: param with: light). "brighten"
+ colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"].
+ ^colorArray!
Item was added:
+ ----- Method: ComplexBorder>>computeColors (in category 'private') -----
+ computeColors
+ width = 0 ifTrue:[^colors := #()].
+ style == #complexFramed ifTrue:[^self computeFramedColors].
+ style == #complexAltFramed ifTrue:[^self computeAltFramedColors].
+ style == #complexRaised ifTrue:[^self computeRaisedColors].
+ style == #complexAltRaised ifTrue:[^self computeAltRaisedColors].
+ style == #complexInset ifTrue:[^self computeInsetColors].
+ style == #complexAltInset ifTrue:[^self computeAltInsetColors].
+ self error:'Unknown border style: ', style printString.!
Item was added:
+ ----- Method: ComplexBorder>>computeFramedColors (in category 'private') -----
+ computeFramedColors
+ | base light dark w hw colorArray param |
+ base := self color asColor.
+ light := Color white.
+ dark := Color black.
+ w := self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width].
+ w := w asInteger.
+ w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}].
+ colorArray := Array new: w.
+ hw := w // 2.
+ "brighten"
+ 0 to: hw-1 do:[:i|
+ param := 0.5 + (i asFloat / hw * 0.5).
+ colorArray at: i+1 put: (base mixed: param with: light). "brighten"
+ colorArray at: w-i put: (base mixed: param with: dark). "darken"
+ ].
+ w odd ifTrue:[colorArray at: hw+1 put: base].
+ ^colorArray, colorArray!
Item was added:
+ ----- Method: ComplexBorder>>computeInsetColors (in category 'private') -----
+ computeInsetColors
+ | base light dark w colorArray param hw |
+ base := self color asColor.
+ light := Color white.
+ dark := Color black.
+ w := self width isPoint
+ ifTrue: [self width x max: self width y]
+ ifFalse: [self width].
+ w := w asInteger.
+ colorArray := Array new: w * 2.
+ hw := 0.5 / w.
+ 0 to: w - 1
+ do:
+ [:i |
+ param := true
+ ifTrue: [ 0.5 + (hw * i)]
+ ifFalse: [0.5 + (hw * (w - i))].
+ colorArray at: i + 1 put: (base mixed: param with: dark). "darken"
+ colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"].
+ ^colorArray!
Item was added:
+ ----- Method: ComplexBorder>>computeRaisedColors (in category 'private') -----
+ computeRaisedColors
+ | base light dark w colorArray param hw |
+ base := self color asColor.
+ light := Color white.
+ dark := Color black.
+ w := self width isPoint
+ ifTrue: [self width x max: self width y]
+ ifFalse: [self width].
+ w := w asInteger.
+ colorArray := Array new: w * 2.
+ hw := 0.5 / w.
+ 0 to: w - 1
+ do:
+ [:i |
+ param := true ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))].
+ colorArray at: i + 1 put: (base mixed: param with: light). "brighten"
+ colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"].
+ ^colorArray!
Item was added:
+ ----- Method: ComplexBorder>>drawLineFrom:to:on: (in category 'drawing') -----
+ drawLineFrom: startPoint to: stopPoint on: aCanvas
+ "Here we're using the balloon engine since this is much faster than BitBlt w/ brushes."
+
+ | delta length dir cos sin tfm w h w1 w2 h1 h2 fill |
+ width isPoint
+ ifTrue:
+ [w := width x.
+ h := width y]
+ ifFalse: [w := h := width].
+ w1 := w // 2.
+ w2 := w - w1.
+ h1 := h // 2.
+ h2 := h - h1.
+ "Compute the rotational transform from (0 at 0) -> (1 at 0) to startPoint -> stopPoint"
+ delta := stopPoint - startPoint.
+ length := delta r.
+ dir := length > 1.0e-10 ifTrue: [delta / length] ifFalse: [ 1 @ 0].
+ cos := dir dotProduct: 1 @ 0.
+ sin := dir crossProduct: 1 @ 0.
+ tfm := (MatrixTransform2x3 new)
+ a11: cos;
+ a12: sin;
+ a21: sin negated;
+ a22: cos.
+ "Install the start point offset"
+ tfm offset: startPoint.
+ "Now get the fill style appropriate for the given direction"
+ fill := self fillStyleForDirection: dir.
+ "And draw..."
+ aCanvas asBalloonCanvas transformBy: tfm
+ during:
+ [:cc |
+ cc drawPolygon: {
+ (0 - w1) @ (0 - h1). "top left"
+ (length + w2) @ (0 - h1). "top right"
+ (length + w2) @ h2. "bottom right"
+ (0 - w1) @ h2 "bottom left"}
+ fillStyle: fill]!
Item was added:
+ ----- Method: ComplexBorder>>drawPolyPatchFrom:to:on:usingEnds: (in category 'drawing') -----
+ drawPolyPatchFrom: startPoint to: stopPoint on: aCanvas usingEnds: endsArray
+
+ | cos sin tfm fill dir fsOrigin fsDirection points x y |
+ dir := (stopPoint - startPoint) normalized.
+ "Compute the rotational transform from (0 at 0) -> (1 at 0) to startPoint -> stopPoint"
+ cos := dir dotProduct: (1 at 0).
+ sin := dir crossProduct: (1 at 0).
+ "Now get the fill style appropriate for the given direction"
+ fill := self fillStyleForDirection: dir.
+ false ifTrue:[
+ "Transform the fill appropriately"
+ fill := fill clone.
+ "Note: Code below is inlined from tfm transformPoint:/transformDirection:"
+ x := fill origin x. y := fill origin y.
+ fsOrigin := ((x * cos) + (y * sin) + startPoint x) @
+ ((y * cos) - (x * sin) + startPoint y).
+ x := fill direction x. y := fill direction y.
+ fsDirection := ((x * cos) + (y * sin)) @ ((y * cos) - (x * sin)).
+ fill origin: fsOrigin;
+ direction: fsDirection rounded; "NOTE: This is a bug in the balloon engine!!!!!!"
+ normal: nil.
+ aCanvas asBalloonCanvas drawPolygon: endsArray fillStyle: fill.
+ ] ifFalse:[
+ "Transform the points rather than the fills"
+ tfm := (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos.
+ "Install the start point offset"
+ tfm offset: startPoint.
+ points := endsArray collect:[:pt| tfm invertPoint: pt].
+ aCanvas asBalloonCanvas transformBy: tfm during:[:cc|
+ cc drawPolygon: points fillStyle: fill.
+ ].
+ ].!
Item was added:
+ ----- Method: ComplexBorder>>fillStyleForDirection: (in category 'private') -----
+ fillStyleForDirection: direction
+ "Fill the given form describing the receiver's look at a particular direction"
+ | index fill dir |
+ index := direction degrees truncated // 10 + 1.
+ lineStyles ifNotNil:[
+ fill := lineStyles at: index.
+ fill ifNotNil:[^fill].
+ ].
+ dir := Point r: 1.0 degrees: index - 1 * 10 + 5.
+ fill := GradientFillStyle colors: (self colorsForDirection: dir).
+ fill direction: 0 @ width asPoint y; radial: false.
+ fill origin: ((width asPoint x // 2) @ (width asPoint y // 2)) negated.
+ fill pixelRamp: (fill computePixelRampOfSize: 16).
+ fill isTranslucent. "precompute"
+ lineStyles ifNil:[lineStyles := Array new: 37].
+ lineStyles at: index put: fill.
+ ^fill!
Item was added:
+ ----- Method: ComplexBorder>>framePolygon2:on: (in category 'drawing') -----
+ framePolygon2: vertices on: aCanvas
+ | dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3
+ cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends |
+ balloon := aCanvas asBalloonCanvas.
+ balloon == aCanvas ifFalse:[balloon deferred: true].
+ ends := Array new: 4.
+ w := width * 0.5.
+ pointA := nil.
+ 1 to: vertices size do:[:i|
+ p1 := vertices atWrap: i.
+ p2 := vertices atWrap: i+1.
+ p3 := vertices atWrap: i+2.
+ p4 := vertices atWrap: i+3.
+
+ dir1 := p2 - p1.
+ dir2 := p3 - p2.
+ dir3 := p4 - p3.
+
+ i = 1 ifTrue:[
+ "Compute the merge points of p1->p2 with p2->p3"
+ cross1 := dir2 crossProduct: dir1.
+ nrm1 := dir1 normalized. nrm1 := (nrm1 y * w) @ (0 - nrm1 x * w).
+ nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w).
+ cross1 < 0 ifTrue:[nrm1 := nrm1 negated. nrm2 := nrm2 negated].
+ point1 := (p1 x + nrm1 x) @ (p1 y + nrm1 y).
+ point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y).
+ pointA := self intersectFrom: point1 with: dir1 to: point2 with: dir2.
+ point1 := (p1 x - nrm1 x) @ (p1 y - nrm1 y).
+ point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y).
+ pointB := self intersectFrom: point1 with: dir1 to: point2 with: dir2.
+ pointB ifNotNil:[
+ (pointB x - p2 x) abs + (pointB y - p2 y) abs > (4*w) ifTrue:[pointA := pointB := nil].
+ ].
+ ].
+
+ "Compute the merge points of p2->p3 with p3->p4"
+ cross2 := dir3 crossProduct: dir2.
+ nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w).
+ nrm3 := dir3 normalized. nrm3 := (nrm3 y * w) @ (0 - nrm3 x * w).
+ cross2 < 0 ifTrue:[nrm2 := nrm2 negated. nrm3 := nrm3 negated].
+ point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y).
+ point3 := (p3 x + nrm3 x) @ (p3 y + nrm3 y).
+ pointC := self intersectFrom: point2 with: dir2 to: point3 with: dir3.
+ point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y).
+ point3 := (p3 x - nrm3 x) @ (p3 y - nrm3 y).
+ pointD := self intersectFrom: point2 with: dir2 to: point3 with: dir3.
+ pointD ifNotNil:[
+ (pointD x - p3 x) abs + (pointD y - p3 y) abs > (4*w) ifTrue:[pointC := pointD := nil].
+ ].
+ cross1 * cross2 < 0.0 ifTrue:[
+ point1 := pointA.
+ pointA := pointB.
+ pointB := point1.
+ cross1 := 0.0 - cross1].
+ ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointD; at: 4 put: pointC.
+ pointA ifNil:["degenerate and slow"
+ nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w).
+ cross1 < 0 ifTrue:[nrm2 := nrm2 negated].
+ point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y).
+ ends at: 1 put: point2].
+ pointB ifNil:["degenerate and slow"
+ nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w).
+ cross1 < 0 ifTrue:[nrm2 := nrm2 negated].
+ point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y).
+ ends at: 2 put: point2].
+ pointC ifNil:["degenerate and slow"
+ nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w).
+ cross2 < 0 ifTrue:[nrm2 := nrm2 negated].
+ point2 := (p3 x + nrm2 x) @ (p3 y + nrm2 y).
+ ends at: 4 put: point2].
+ pointD ifNil:["degenerate and slow"
+ nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w).
+ cross2 < 0 ifTrue:[nrm2 := nrm2 negated].
+ point2 := (p3 x - nrm2 x) @ (p3 y - nrm2 y).
+ ends at: 3 put: point2].
+
+ self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends.
+ pointA := pointC.
+ pointB := pointD.
+ cross1 := cross2.
+ ].
+ balloon == aCanvas ifFalse:[balloon flush].!
Item was added:
+ ----- Method: ComplexBorder>>framePolygon:on: (in category 'drawing') -----
+ framePolygon: vertices on: aCanvas
+ | dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3
+ cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends pointE pointF |
+ balloon := aCanvas asBalloonCanvas.
+ balloon == aCanvas ifFalse:[balloon deferred: true].
+ ends := Array new: 6.
+ w := width * 0.5.
+ pointA := nil.
+ 1 to: vertices size do:[:i|
+ p1 := vertices atWrap: i.
+ p2 := vertices atWrap: i+1.
+ p3 := vertices atWrap: i+2.
+ p4 := vertices atWrap: i+3.
+
+ dir1 := p2 - p1.
+ dir2 := p3 - p2.
+ dir3 := p4 - p3.
+
+ (i = 1 | true) ifTrue:[
+ "Compute the merge points of p1->p2 with p2->p3"
+ cross1 := dir2 crossProduct: dir1.
+ nrm1 := dir1 normalized. nrm1 := (nrm1 y * w) @ (0 - nrm1 x * w).
+ nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w).
+ cross1 < 0 ifTrue:[nrm1 := nrm1 negated. nrm2 := nrm2 negated].
+ point1 := (p1 x + nrm1 x) @ (p1 y + nrm1 y).
+ point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y).
+ pointA := self intersectFrom: point1 with: dir1 to: point2 with: dir2.
+ point1 := (p1 x - nrm1 x) @ (p1 y - nrm1 y).
+ point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y).
+ pointB := point1 + dir1 + point2 * 0.5.
+ pointB := p2 + ((pointB - p2) normalized * w).
+ pointC := point2.
+ ].
+
+ "Compute the merge points of p2->p3 with p3->p4"
+ cross2 := dir3 crossProduct: dir2.
+ nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w).
+ nrm3 := dir3 normalized. nrm3 := (nrm3 y * w) @ (0 - nrm3 x * w).
+ cross2 < 0 ifTrue:[nrm2 := nrm2 negated. nrm3 := nrm3 negated].
+ point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y).
+ point3 := (p3 x + nrm3 x) @ (p3 y + nrm3 y).
+ pointD := self intersectFrom: point2 with: dir2 to: point3 with: dir3.
+ point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y).
+ point3 := (p3 x - nrm3 x) @ (p3 y - nrm3 y).
+ pointF := point2 + dir2.
+ pointE := pointF + point3 * 0.5.
+ pointE := p3 + ((pointE - p3) normalized * w).
+ cross1 * cross2 < 0.0 ifTrue:[
+ ends
+ at: 1 put: pointA;
+ at: 2 put: pointB;
+ at: 3 put: pointC;
+ at: 4 put: pointD;
+ at: 5 put: pointE;
+ at: 6 put: pointF.
+ ] ifFalse:[
+ ends
+ at: 1 put: pointA;
+ at: 2 put: pointB;
+ at: 3 put: pointC;
+ at: 4 put: pointF;
+ at: 5 put: pointE;
+ at: 6 put: pointD.
+ ].
+ self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends.
+ pointA := pointD.
+ pointB := pointE.
+ pointC := pointF.
+ cross1 := cross2.
+ ].
+ balloon == aCanvas ifFalse:[balloon flush].!
Item was added:
+ ----- Method: ComplexBorder>>frameRectangle:on: (in category 'drawing') -----
+ frameRectangle: aRectangle on: aCanvas
+ "Note: This uses BitBlt since it's roughly a factor of two faster for rectangles"
+ | w h r |
+ self colors ifNil:[^super frameRectangle: aRectangle on: aCanvas].
+ w := self width.
+ w isPoint ifTrue:[h := w y. w := w x] ifFalse:[h := w].
+ 1 to: h do:[:i| "top/bottom"
+ r := (aRectangle topLeft + (i-1)) extent: (aRectangle width - (i-1*2))@1. "top"
+ aCanvas fillRectangle: r color: (colors at: i).
+ r := (aRectangle bottomLeft + (i @ (0-i))) extent: (aRectangle width - (i-1*2) - 1)@1. "bottom"
+ aCanvas fillRectangle: r color: (colors at: colors size - i + 1).
+ ].
+ 1 to: w do:[:i| "left/right"
+ r := (aRectangle topLeft + (i-1)) extent: 1@(aRectangle height - (i-1*2)). "left"
+ aCanvas fillRectangle: r color: (colors at: i).
+ r := aRectangle topRight + ((0-i)@i) extent: 1@(aRectangle height - (i-1*2) - 1). "right"
+ aCanvas fillRectangle: r color: (colors at: colors size - i + 1).
+ ].!
Item was added:
+ ----- Method: ComplexBorder>>intersectFrom:with:to:with: (in category 'private') -----
+ intersectFrom: startPt with: startDir to: endPt with: endDir
+ "Compute the intersection of two lines. Return nil if either
+ * the intersection does not exist, or
+ * the intersection is 'before' startPt, or
+ * the intersection is 'after' endPt
+ "
+ | det deltaPt alpha beta |
+ det := (startDir x * endDir y) - (startDir y * endDir x).
+ det = 0.0 ifTrue:[^nil]. "There's no solution for it"
+ deltaPt := endPt - startPt.
+ alpha := (deltaPt x * endDir y) - (deltaPt y * endDir x).
+ beta := (deltaPt x * startDir y) - (deltaPt y * startDir x).
+ alpha := alpha / det.
+ beta := beta / det.
+ alpha < 0 ifTrue:[^nil].
+ beta > 1.0 ifTrue:[^nil].
+ "And compute intersection"
+ ^(startPt x + (alpha * startDir x)) @ (startPt y + (alpha * startDir y))!
Item was added:
+ ----- Method: ComplexBorder>>isComplex (in category 'testing') -----
+ isComplex
+ ^true!
Item was added:
+ ----- Method: ComplexBorder>>releaseCachedState (in category 'initialize') -----
+ releaseCachedState
+ colors := nil.
+ lineStyles := nil.!
Item was added:
+ ----- Method: ComplexBorder>>style (in category 'accessing') -----
+ style
+ ^style!
Item was added:
+ ----- Method: ComplexBorder>>style: (in category 'accessing') -----
+ style: newStyle
+ style == newStyle ifTrue:[^self].
+ style := newStyle.
+ self releaseCachedState.!
Item was added:
+ ----- Method: ComplexBorder>>trackColorFrom: (in category 'color tracking') -----
+ trackColorFrom: aMorph
+ baseColor ifNil:[self color: aMorph raisedColor].!
Item was added:
+ ----- Method: ComplexBorder>>widthForRounding (in category 'accessing') -----
+ widthForRounding
+ ^0!
Item was added:
+ Object subclass: #ComplexProgressIndicator
+ instanceVariableNames: 'formerWorld targetMorph estimate prevData formerProcess translucentMorph userSuppliedMorph specificHistory historyCategory cumulativeStageTime formerProject newRatio stageCompleted start'
+ classVariableNames: 'History'
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !ComplexProgressIndicator commentStamp: '<historical>' prior: 0!
+ Note: in an effort to remove the progress indicator if a walkback occurs, #withProgressDo: must be sent from the current uiProcess. Hopefully we can relax this restriction in the future. !
Item was added:
+ ----- Method: ComplexProgressIndicator class>>historyReport (in category 'as yet unclassified') -----
+ historyReport
+ "
+ ComplexProgressIndicator historyReport
+ "
+ | answer |
+ History ifNil: [^Beeper beep].
+ answer := String streamContents: [ :strm |
+ (History keys asArray sort: [ :a :b | a asString <= b asString]) do: [ :k |
+ | data |
+ strm nextPutAll: k printString; cr.
+ data := History at: k.
+ (data keys asArray sort: [ :a :b | a asString <= b asString]) do: [ :dataKey |
+ strm tab; nextPutAll: dataKey printString,' ',
+ (data at: dataKey) asArray printString; cr.
+ ].
+ strm cr.
+ ].
+ ].
+ StringHolder new
+ contents: answer contents;
+ openLabel: 'Progress History'!
Item was added:
+ ----- Method: ComplexProgressIndicator>>addProgressDecoration: (in category 'as yet unclassified') -----
+ addProgressDecoration: extraParam
+ | f m |
+ targetMorph ifNil: [^self].
+ (extraParam isForm)
+ ifTrue:
+ [targetMorph
+ submorphsDo: [:mm | (mm isSketchMorph) ifTrue: [mm delete]].
+ f := Form extent: extraParam extent depth: extraParam depth.
+ extraParam displayOn: f.
+ m := SketchMorph withForm: f.
+ m align: m fullBounds leftCenter
+ with: targetMorph fullBounds leftCenter + (2 @ 0).
+ targetMorph addMorph: m.
+ ^self].
+ (extraParam isString)
+ ifTrue:
+ [targetMorph
+ submorphsDo: [:mm | (mm isKindOf: StringMorph) ifTrue: [mm delete]].
+ m := StringMorph contents: extraParam translated.
+ m align: m fullBounds bottomCenter + (0 @ 8)
+ with: targetMorph bounds bottomCenter.
+ targetMorph addMorph: m.
+ ^self]!
Item was added:
+ ----- Method: ComplexProgressIndicator>>backgroundWorldDisplay (in category 'as yet unclassified') -----
+ backgroundWorldDisplay
+
+ self flag: #bob. "really need a better way to do this"
+
+ "World displayWorldSafely."
+
+ "ugliness to try to track down a possible error"
+
+
+ [World displayWorld] ifError: [ :a :b |
+ | f |
+ stageCompleted := 999.
+ f := FileDirectory default fileNamed: 'bob.errors'.
+ f nextPutAll: a printString,' ',b printString; cr; cr.
+ f nextPutAll: 'worlds equal ',(formerWorld == World) printString; cr; cr.
+ f nextPutAll: thisContext longStack; cr; cr.
+ f nextPutAll: formerProcess suspendedContext longStack; cr; cr.
+ f close. Beeper beep.
+ ].
+ !
Item was added:
+ ----- Method: ComplexProgressIndicator>>forkProgressWatcher (in category 'as yet unclassified') -----
+ forkProgressWatcher
+
+ [
+ | killTarget |
+ [stageCompleted < 999 and:
+ [formerProject == Project current and:
+ [formerWorld == World and:
+ [translucentMorph world notNil and:
+ [formerProcess suspendedContext notNil and:
+ [Project uiProcess == formerProcess]]]]]] whileTrue: [
+
+ translucentMorph setProperty: #revealTimes toValue:
+ {(Time millisecondClockValue - start max: 1). (estimate * newRatio max: 1)}.
+ translucentMorph changed.
+ translucentMorph owner addMorphInLayer: translucentMorph.
+ (Time millisecondClockValue - WorldState lastCycleTime) abs > 500 ifTrue: [
+ self backgroundWorldDisplay
+ ].
+ (Delay forMilliseconds: 100) wait.
+ ].
+ translucentMorph removeProperty: #revealTimes.
+ self loadingHistoryAt: 'total' add: (Time millisecondClockValue - start max: 1).
+ killTarget := targetMorph ifNotNil: [
+ targetMorph valueOfProperty: #deleteOnProgressCompletion
+ ].
+ formerWorld == World ifTrue: [
+ translucentMorph delete.
+ killTarget ifNotNil: [killTarget delete].
+ ] ifFalse: [
+ translucentMorph privateDeleteWithAbsolutelyNoSideEffects.
+ killTarget ifNotNil: [killTarget privateDeleteWithAbsolutelyNoSideEffects].
+ ].
+ ] forkAt: Processor lowIOPriority.!
Item was added:
+ ----- Method: ComplexProgressIndicator>>historyCategory: (in category 'as yet unclassified') -----
+ historyCategory: aKey
+
+ History ifNil: [History := Dictionary new].
+ specificHistory := History
+ at: aKey
+ ifAbsentPut: [Dictionary new].
+ ^specificHistory
+ !
Item was added:
+ ----- Method: ComplexProgressIndicator>>loadingHistoryAt:add: (in category 'as yet unclassified') -----
+ loadingHistoryAt: aKey add: aNumber
+
+ (self loadingHistoryDataForKey: aKey) add: aNumber.
+
+ !
Item was added:
+ ----- Method: ComplexProgressIndicator>>loadingHistoryDataForKey: (in category 'as yet unclassified') -----
+ loadingHistoryDataForKey: anObject
+
+ | answer |
+ answer := specificHistory
+ at: anObject
+ ifAbsentPut: [OrderedCollection new].
+ answer size > 50 ifTrue: [
+ answer := answer copyFrom: 25 to: answer size.
+ specificHistory at: anObject put: answer.
+ ].
+ ^answer
+
+ !
Item was added:
+ ----- Method: ComplexProgressIndicator>>targetMorph: (in category 'as yet unclassified') -----
+ targetMorph: aMorph
+
+ targetMorph := aMorph!
Item was added:
+ ----- Method: ComplexProgressIndicator>>withProgressDo: (in category 'as yet unclassified') -----
+ withProgressDo: aBlock
+
+ | safetyFactor totals trialRect delta targetOwner |
+
+ Smalltalk isMorphic ifFalse: [^aBlock value].
+ formerProject := Project current.
+ formerWorld := World.
+ formerProcess := Processor activeProcess.
+ targetMorph
+ ifNil: [targetMorph := ProgressTargetRequestNotification signal].
+ targetMorph ifNil: [
+ trialRect := Rectangle center: Sensor cursorPoint extent: 80 at 80.
+ delta := trialRect amountToTranslateWithin: formerWorld bounds.
+ trialRect := trialRect translateBy: delta.
+ translucentMorph := TranslucentProgessMorph new
+ opaqueBackgroundColor: Color white;
+ bounds: trialRect;
+ openInWorld: formerWorld.
+ ] ifNotNil: [
+ targetOwner := targetMorph owner.
+ translucentMorph := TranslucentProgessMorph new
+ setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1;
+ bounds: targetMorph boundsInWorld;
+ openInWorld: targetMorph world.
+ ].
+ stageCompleted := 0.
+ safetyFactor := 1.1. "better to guess high than low"
+ translucentMorph setProperty: #progressStageNumber toValue: 1.
+ translucentMorph hide.
+ targetOwner ifNotNil: [targetOwner hide].
+ totals := self loadingHistoryDataForKey: 'total'.
+ newRatio := 1.0.
+ estimate := totals size < 2 ifTrue: [
+ 15000 "be a pessimist"
+ ] ifFalse: [
+ (totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor.
+ ].
+ start := Time millisecondClockValue.
+ self forkProgressWatcher.
+
+ [
+ aBlock
+ on: ProgressInitiationException
+ do: [ :ex |
+ ex sendNotificationsTo: [ :min :max :curr |
+ "ignore this as it is inaccurate"
+ ].
+ ].
+ ] on: ProgressNotification do: [ :note | | stageCompletedString |
+ translucentMorph show.
+ targetOwner ifNotNil: [targetOwner show].
+ note extraParam ifNotNil:[self addProgressDecoration: note extraParam].
+ stageCompletedString := (note messageText findTokens: ' ') first.
+ stageCompleted := (stageCompletedString copyUpTo: $:) asNumber.
+ cumulativeStageTime := Time millisecondClockValue - start max: 1.
+ prevData := self loadingHistoryDataForKey: stageCompletedString.
+ prevData isEmpty ifFalse: [
+ newRatio := (cumulativeStageTime / (prevData average max: 1)) asFloat.
+ ].
+ self
+ loadingHistoryAt: stageCompletedString
+ add: cumulativeStageTime.
+ translucentMorph
+ setProperty: #progressStageNumber
+ toValue: stageCompleted + 1.
+ note resume.
+ ].
+
+ stageCompleted := 999. "we may or may not get here"
+
+ !
Item was added:
+ AbstractResizerMorph subclass: #CornerGripMorph
+ instanceVariableNames: 'target'
+ classVariableNames: 'ActiveForm DrawCornerResizeHandles PassiveForm'
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !CornerGripMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0!
+ I am the superclass of a hierarchy of morph specialized in allowing the user to resize windows.!
Item was added:
+ ----- Method: CornerGripMorph class>>activeColor (in category 'handle settings') -----
+ activeColor
+ <preference: 'Corner Grip highlight color'
+ category: 'window colors'
+ description: 'The highlight-color of window corners'
+ type: #Color>
+ ^(self activeForm colorAt: 24 at 24) alpha: 1!
Item was added:
+ ----- Method: CornerGripMorph class>>activeColor: (in category 'handle settings') -----
+ activeColor: aColor
+ |canvas|
+ canvas := self initializeActiveForm getCanvas.
+ canvas
+ privatePort fillPattern: aColor;
+ combinationRule: Form rgbMul;
+ fillRect: (self activeForm boundingBox) offset: 0 at 0.
+
+ !
Item was added:
+ ----- Method: CornerGripMorph class>>activeForm (in category 'accessing') -----
+ activeForm
+ ^ActiveForm ifNil: [self initializeActiveForm]!
Item was added:
+ ----- Method: CornerGripMorph class>>defaultForm (in category 'class initialization') -----
(excessive size, no diff calculated)
Item was added:
+ ----- Method: CornerGripMorph class>>defaultFormFromFileNamed: (in category 'handle settings') -----
+ defaultFormFromFileNamed: aString
+ "If you dislike the alpha scale of the default handle, use this method to install a new one.
+ File should be in a readable image format, and contain a 48x48 32bit radial gradient with color white.
+ Use passiveColor: / activeColor: to change them after file is loaded, see initialize for an example"
+
+ |sourceStream|
+ sourceStream := WriteStream on: String new.
+ sourceStream nextPutAll: 'defaultForm';
+ nextPut: Character cr;
+ nextPut: Character cr;
+ nextPut: $^;
+ nextPut: $(;
+ nextPutAll: (ImageReadWriter formFromFileNamed: aString) storeString;
+ nextPut: $).
+ self class compile: sourceStream contents.!
Item was added:
+ ----- Method: CornerGripMorph class>>drawCornerResizeHandles (in category 'preferences') -----
+ drawCornerResizeHandles
+ <preference: 'Draw Corner Resize Handles'
+ category: 'windows'
+ description: 'Governs the resize handles on windows should be drawn. This does not disable them'
+ type: #Boolean>
+ ^ DrawCornerResizeHandles ifNil: [ false ]!
Item was added:
+ ----- Method: CornerGripMorph class>>drawCornerResizeHandles: (in category 'preferences') -----
+ drawCornerResizeHandles: aBoolean
+
+ DrawCornerResizeHandles := aBoolean.
+ World invalidRect: World bounds from: World.!
Item was added:
+ ----- Method: CornerGripMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "CornerGripMorph initialize"
+
+ super initialize.
+ self initializeActiveForm.
+ self initializePassiveForm.
+ self activeColor: Color orange.!
Item was added:
+ ----- Method: CornerGripMorph class>>initializeActiveForm (in category 'class initialization') -----
+ initializeActiveForm
+
+ ^ActiveForm := self defaultForm!
Item was added:
+ ----- Method: CornerGripMorph class>>initializePassiveForm (in category 'class initialization') -----
+ initializePassiveForm
+
+ ^PassiveForm := self defaultForm!
Item was added:
+ ----- Method: CornerGripMorph class>>passiveColor (in category 'handle settings') -----
+ passiveColor
+ <preference: 'Corner Grip color'
+ category: 'window colors'
+ description: 'The default color of window corners'
+ type: #Color>
+ ^(self passiveForm colorAt: 24 at 24) alpha: 1!
Item was added:
+ ----- Method: CornerGripMorph class>>passiveColor: (in category 'handle settings') -----
+ passiveColor: aColor
+ | canvas |
+ canvas := self initializePassiveForm getCanvas.
+ canvas privatePort fillPattern: aColor;
+ combinationRule: Form rgbMul;
+ fillRect: self passiveForm boundingBox offset: 0 @ 0.
+ self
+ allSubInstancesDo: [:each | each setDefaultColors; changed]!
Item was added:
+ ----- Method: CornerGripMorph class>>passiveForm (in category 'accessing') -----
+ passiveForm
+ ^PassiveForm ifNil: [self initializePassiveForm]!
Item was added:
+ ----- Method: CornerGripMorph>>activeForm (in category 'private') -----
+ activeForm
+ ^self clipForm: self class activeForm!
Item was added:
+ ----- Method: CornerGripMorph>>alphaHandle (in category 'drawing') -----
+ alphaHandle
+
+ handleColor ifNil: [handleColor := self passiveForm].
+ "The following line is only needed on first load, so existing windows don't blow up from the new handles.
+ Can safely be deleted along with this comment in a later update"
+ (handleColor class == Form)
+ ifFalse: [handleColor := self passiveForm].
+ ^handleColor
+
+
+ !
Item was added:
+ ----- Method: CornerGripMorph>>borderOffset (in category 'private') -----
+ borderOffset
+ "The offset from my corner to where the border starts"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: CornerGripMorph>>clipForm: (in category 'private') -----
+ clipForm: aHandle
+ |cutArea|
+ "This doesn't really needs to be done every draw, but only if border width changes.
+ In that case,, we'd have to install a newly initialized one anyways, so the current method will fail.
+ Good enough for now though."
+ cutArea := self transparentRectangle.
+ aHandle getCanvas image: cutArea
+ at: self borderOffset
+ sourceRect: cutArea boundingBox
+ rule: Form and.
+ ^aHandle
+
+ !
Item was added:
+ ----- Method: CornerGripMorph>>defaultHeight (in category 'accessing') -----
+ defaultHeight
+ ^ 22!
Item was added:
+ ----- Method: CornerGripMorph>>defaultWidth (in category 'accessing') -----
+ defaultWidth
+ ^ 22!
Item was added:
+ ----- Method: CornerGripMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ self class drawCornerResizeHandles
+ ifTrue: [
+ bounds := self bounds.
+ aCanvas
+ translucentImage: (self alphaHandle)
+ at: (bounds origin )
+ sourceRect: (self handleOrigin extent: bounds extent)]!
Item was added:
+ ----- Method: CornerGripMorph>>handleOrigin (in category 'private') -----
+ handleOrigin
+ "The handles origin is the offset into the alphaForm"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: CornerGripMorph>>handlesMouseDown: (in category 'as yet unclassified') -----
+ handlesMouseDown: anEvent
+ ^ true!
Item was added:
+ ----- Method: CornerGripMorph>>handlesMouseOver: (in category 'as yet unclassified') -----
+ handlesMouseOver: anEvent
+ ^true!
Item was added:
+ ----- Method: CornerGripMorph>>initialize (in category 'as yet unclassified') -----
+ initialize
+ super initialize.
+ self extent: self defaultWidth+2 @ (self defaultHeight+2).
+ self layoutFrame: self gripLayoutFrame!
Item was added:
+ ----- Method: CornerGripMorph>>mouseMove: (in category 'as yet unclassified') -----
+ mouseMove: anEvent
+ | delta |
+ target ifNil: [^ self].
+ target fastFramingOn
+ ifTrue: [delta := target doFastWindowReframe: self ptName]
+ ifFalse: [
+ delta := anEvent cursorPoint - lastMouse.
+ lastMouse := anEvent cursorPoint.
+ self apply: delta.
+ self bounds: (self bounds origin + delta extent: self bounds extent)].!
Item was added:
+ ----- Method: CornerGripMorph>>passiveForm (in category 'private') -----
+ passiveForm
+ ^self clipForm: self class passiveForm!
Item was added:
+ ----- Method: CornerGripMorph>>setDefaultColors (in category 'private') -----
+ setDefaultColors
+
+ handleColor := self passiveForm.!
Item was added:
+ ----- Method: CornerGripMorph>>setInverseColors (in category 'private') -----
+ setInverseColors
+ handleColor := self activeForm.!
Item was added:
+ ----- Method: CornerGripMorph>>target: (in category 'as yet unclassified') -----
+ target: aMorph
+
+ target := aMorph!
Item was added:
+ ----- Method: CornerGripMorph>>transparentRectangle (in category 'private') -----
+ transparentRectangle
+ "This could be a class var, provided either bounds of grips does not change, or one ensures a new one is installed when such an event occurs"
+ ^Form extent: self bounds extent depth: 32!
Item was added:
+ Array variableSubclass: #Cubic
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Collections-Arrayed'!
+
+ !Cubic commentStamp: 'wiz 6/17/2004 20:31' prior: 0!
+ I am a segment between to points. In the form of a cubic polynomial that can be evaluated between 0..1 to obtain the end points and intermediate values.
+ !
Item was added:
+ ----- Method: Cubic>>bestSegments (in category 'cubic support') -----
+ bestSegments
+ "Return the smallest integer number of segments that give the
+ best curve."
+ ^ self honeIn: self calcEnoughSegments!
Item was added:
+ ----- Method: Cubic>>calcEnoughSegments (in category 'cubic support') -----
+ calcEnoughSegments
+ "Find the power of two that represents a sufficient number of
+ segments for this cubic.
+ The measure is the sum of distances for the segments.
+ We want this to be close enough not affect the straightness of
+ the drawn lines. Which means within one pixel."
+ "^ self
+ enough: 2
+ withMeasure: (self measureFor: 1)
+ withIn: self leeway
+ This ran into a problem when the curve was an s-curve with
+ inflections. Besides honeIn will check to see if 1 is better than
+ two so we lose nothing by starting a little higher."
+ ^ self
+ enough: 4
+ withMeasure: (self measureFor: 2)
+ withIn: self leeway!
Item was added:
+ ----- Method: Cubic>>enough:withMeasure:withIn: (in category 'cubic support') -----
+ enough: nTry withMeasure: lastMeasure withIn: closeEnough
+ "See comment in calcEnoughSegments for which I am a helper"
+ | measure |
+ measure := self measureFor: nTry.
+ measure > (lastMeasure + closeEnough)
+ ifFalse: [^ nTry // 2].
+ ^ self
+ enough: 2 * nTry
+ withMeasure: measure
+ withIn: closeEnough!
Item was added:
+ ----- Method: Cubic>>honeIn: (in category 'cubic support') -----
+ honeIn: enough
+ "Find if there is a smaller n than enough that give the same
+ measure for n."
+
+ enough < 2 ifTrue: [ ^enough].
+ ^ self
+ honeIn: enough
+ step: enough // 2
+ measure: (self measureFor: enough)
+ withIn: self leeway!
Item was added:
+ ----- Method: Cubic>>honeIn:step:measure:withIn: (in category 'cubic support') -----
+ honeIn: centerN step: step measure: measure withIn: closeEnough
+ "Pick the best n by binary search."
+ | nTry |
+ step < 1
+ ifTrue: [^ centerN].
+ nTry := centerN - step.
+ ^ measure > (closeEnough
+ + (self measureFor: nTry))
+ ifTrue: [self
+ honeIn: centerN
+ step: step // 2
+ measure: measure
+ withIn: closeEnough]
+ ifFalse: [self
+ honeIn: nTry
+ step: step // 2
+ measure: measure
+ withIn: closeEnough]!
Item was added:
+ ----- Method: Cubic>>leeway (in category 'cubic support') -----
+ leeway
+ "How close can measure be"
+ ^ 0.1!
Item was added:
+ ----- Method: Cubic>>measureFor: (in category 'cubic support') -----
+ measureFor: n
+ "Return a distance measure for cubic curve with n segments.
+ For convienence and accuracy we use the sum of the
+ distances. "
+ "first point is poly of 0."
+ | p1 measure |
+ p1 := self at: 1.
+ measure := 0.
+ 1 to: n do: [ :i |
+ | x p2 |
+ x := i asFloat / n.
+ p2 := self polynomialEval: x @ x.
+ measure := measure + (p2 dist: p1).
+ p1 := p2 ].
+ ^measure!
Item was added:
+ PolygonMorph subclass: #CurveMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !CurveMorph commentStamp: '<historical>' prior: 0!
+ This is really only a shell for creating Shapes with smooth outlines.!
Item was added:
+ ----- Method: CurveMorph class>>arrowPrototype (in category 'instance creation') -----
+ arrowPrototype
+
+ | aa |
+ aa := PolygonMorph vertices: (Array with: 5 at 40 with: 5 at 8 with: 35 at 8 with: 35 at 40)
+ color: Color black
+ borderWidth: 2
+ borderColor: Color black.
+ aa beSmoothCurve; makeOpen; makeForwardArrow. "is already open"
+ aa dashedBorder: {10. 10. Color red}.
+ "A dash spec is a 3- or 5-element array with
+ { length of normal border color.
+ length of alternate border color.
+ alternate border color}"
+ aa computeBounds.
+ ^ aa!
Item was added:
+ ----- Method: CurveMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Curve'
+ categories: #('Graphics' 'Basic')
+ documentation: 'A smooth wiggly curve, or a curved solid. Shift-click to get handles and move the points.'!
Item was added:
+ ----- Method: CurveMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ self beSmoothCurve.
+ !
Item was added:
+ ----- Method: CurveMorph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+
+ super initializeToStandAlone.
+ self beSmoothCurve.
+ !
Item was added:
+ ----- Method: CurveMorph>>isCurvier (in category 'testing') -----
+ isCurvier
+ "Test used by smoothing routines. If true use true closed curve splines for closed curves. If not mimic old stodgy curveMorph curves with one sharp bend. Curve overrides this test for backward compatability.."
+ ^ (false)!
Item was added:
+ PolygonMorph subclass: #CurvierMorph
+ instanceVariableNames: ''
+ classVariableNames: 'DrawCurvier SlopeConstantsCache'
+ poolDictionaries: ''
+ category: 'Morphic-Basic-NewCurve'!
+
+ !CurvierMorph commentStamp: '<historical>' prior: 0!
+ I want to be merged into PolygonMorph.
+ I implement Closed Cubic Curves and restructured routines to ease maintence and development.
+
+
+
+ New way to calculate curves.
+
+ cVariables
+ SlopeConstantsCache anArray size 2 indexed by nVerts \\2 .
+ Each element is an array of integers. The integers represent the constants for
+ calculating slopes for closed cubic curves from the vertices.
+
+
+
+
+ Class Variable SlopeConstantsCache holds a pair of arrays for even and odd number of vertices( aka knots).
+ Each array holds a series of constants in Integer form.
+ This allows slopes to be calculated directly from the array of knots.
+ Wonderfully it turns out that only two arrays are needed.
+ By matching up the knots equidistant from the point in question;
+ Summing the weighted differences of the pairs the unscaled slope can be arrived at.
+ The scale needed to get the slopes needed is trice the reciprical of the next integer in the series.
+ We leave the division til last to get the full benifit of the integer arithmetic.
+
+ Rounding the vertices before calculation is recommended.
+
+
+ Instead of calculating the number of curve subsegments in lineSegDo we add a ninth array to curve state to allow the number to be precalculated.
+ Getting better looking curves motivates finding a better way of guessing n. So this provides a framework for trying.
+
+ For the first pass we just used the constant 12 for every thing.
+ In the second pass we judge the number of segments by starting with two and doubling the number until the distance of the curve no longer increases.
+ Then we hone in using a binary search to find the smallest number of segments with that same curve length.
+
+
+ We have changed some assumptions. Previously curves were figured by solving for the second derivative first and using the results to determine the slope and the third derivative. So lineSegDo counted on the last second deriv being a number it could use in its calculation of the number of subsegments.
+
+ Currently we just solve for slopes and the second and third derivs are derived from that.
+ Also the derivation for the second and third derivs only assume C(1) (first derivitive continuity). The calculations for the slopes are the only calcs using C(2) continuity. Therefore the slopes can alternately be chosen to fit some other chriteria and the resulting curves will still be smooth to the first degree.
+ A useful variant of closed slopes is to scale them by a constant.
+
+
+ Also the last of each element of curvestate always reflects a closing segment. And we don't add an extra row for closed curves anymore.
+ That is now lineSegDo's responsibility to be aware of as it was already doing with segmented curves. So the last n does not track its old value.
+
+ Preferences:
+ A Preference has been added to toggle between the old (ugly) closed curves based on natural cubic slopes and the new smooth algorythim. This doesn't make much difference while newcurves are a subclass of polygons but the ambition is for newcurves to supercede polygons. This will allow backwards compatibility.
+
+ Shapes: With closed curves a smooth oval results from rectagular or diamond vertices. So two menuitems have been added (to PolygonMorph) that allow the vertices to be set to these shapes using the current bounds of the polygon. The former state of vertices will be lost but it seems useful to lose a complicated shape and start fresh with a simple symmetrical one.
+
+ Furthur on: Modify curveState to only contain slope and higher deriv information. Let the information about the knots only be held only in the vertices of the polygon. Once that is done curvestate will not have to be recalcutaled each time the polygon is moved but only when its shape changes.
+
+ There is also some possible speed up to be had by refining or experimenting with other number of segment calculating schemes but not as much as preserving curvestate over a move.
+
+ Furthur furthur on: Figure out how to combine straight and curved segments into a single shape in a pleasing way.
+
+
+
+
+
+
+
+
+
+ !
Item was added:
+ ----- Method: CurvierMorph class>>Curvier (in category 'class initialization') -----
+ Curvier
+ <preference: 'Curvier'
+ category: 'morphic'
+ description: 'If true, closed CurvierMorphs will be smoother and more symmetrical all about. If false they will mimic the old curve shapes with the one sharp bend.'
+ type: #Boolean>
+ ^ self drawCurvier.!
Item was added:
+ ----- Method: CurvierMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ "We are very much like curve only better looking."
+ ^ self
+ partName: 'Curvier'
+ categories: #('Graphics' 'Basic' )
+ documentation: 'A smooth wiggly curve, or a smooth curved solid without bends. Shift-click to get handles and move the points.'!
Item was added:
+ ----- Method: CurvierMorph class>>drawCurvier (in category 'class initialization') -----
+ drawCurvier
+ ^ DrawCurvier.!
Item was added:
+ ----- Method: CurvierMorph class>>drawCurvier: (in category 'class initialization') -----
+ drawCurvier: aBoolean
+ DrawCurvier := aBoolean.!
Item was added:
+ ----- Method: CurvierMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "CurvierMorph initialize"
+ Preferences
+ preferenceAt: #Curvier
+ ifAbsent: [Preferences
+ addPreference: #Curvier
+ category: #morphic
+ default: true
+ balloonHelp: 'if true, closed CurvierMorphs will be smoother and more symmetrical all about. If false they will mimic the old curve shapes with the one sharp bend.'].
+ self registerInFlapsRegistry!
Item was added:
+ ----- Method: CurvierMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
+ registerInFlapsRegistry
+ "Register the receiver in the system's flaps registry"
+ self environment
+ at: #Flaps
+ ifPresent: [:cl |
+ cl registerQuad: #(#CurvierMorph #authoringPrototype 'Curvier' 'A curve' ) forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: #(#CurvierMorph #authoringPrototype 'Curvier' 'A curve' ) forFlapNamed: 'Supplies']!
Item was added:
+ ----- Method: CurvierMorph>>initialize (in category 'initialization') -----
+ initialize
+ "We use an oval shape because we wear it well."
+ super initialize.
+ self beSmoothCurve.
+ self diamondOval!
Item was added:
+ ----- Method: CustomMenu>>startUp:withCaption:at: (in category '*Morphic-invocation') -----
+ startUp: initialSelection withCaption: caption at: aPoint
+ "Build and invoke this menu with the given initial selection and caption.
+ Answer the selection associated with the menu item chosen by the user
+ or nil if none is chosen."
+ self build.
+ initialSelection notNil
+ ifTrue: [self preSelect: initialSelection].
+ ^ super startUpWithCaption: caption at: aPoint!
Item was added:
+ ----- Method: CustomMenu>>startUpWithCaption:at: (in category '*Morphic-invocation') -----
+ startUpWithCaption: caption at: aPoint
+ "Build and invoke this menu with no initial selection. Answer the
+ selection associated with the menu item chosen by the user or nil if
+ none is chosen; use the provided caption"
+ ^ self startUp: nil withCaption: caption at: aPoint!
Item was added:
+ Object subclass: #DamageRecorder
+ instanceVariableNames: 'invalidRects totalRepaint'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: DamageRecorder class>>new (in category 'instance creation') -----
+ new
+
+ ^ super new reset
+ !
Item was added:
+ ----- Method: DamageRecorder>>doFullRepaint (in category 'recording') -----
+ doFullRepaint
+ "Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset."
+
+ ^ totalRepaint := true.
+ !
Item was added:
+ ----- Method: DamageRecorder>>invalidRectsFullBounds: (in category 'recording') -----
+ invalidRectsFullBounds: aRectangle
+ "Return a collection of damaged rectangles for the given canvas. If a total repaint has been requested, return the given rectangle."
+
+ totalRepaint
+ ifTrue: [^ Array with: aRectangle]
+ ifFalse: [^ invalidRects copy].
+
+ !
Item was added:
+ ----- Method: DamageRecorder>>recordInvalidRect: (in category 'recording') -----
+ recordInvalidRect: newRect
+ "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle."
+ "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle."
+
+ | mergeRect |
+ totalRepaint ifTrue: [^ self]. "planning full repaint; don't bother collecting damage"
+
+ invalidRects do:
+ [:rect |
+ | a |
+ ((a := (rect intersect: newRect) area) > 40
+ and: ["Avoid combining a vertical and horizontal rects.
+ Can make a big diff and we only test when likely."
+ a > (newRect area // 4) or: [a > (rect area // 4)]])
+ ifTrue:
+ ["merge rectangle in place (see note below) if there is significant overlap"
+ rect setOrigin: (rect origin min: newRect origin) truncated
+ corner: (rect corner max: newRect corner) truncated.
+ ^ self]].
+
+
+ invalidRects size >= 15 ifTrue:
+ ["if there are too many separate areas, merge them all"
+ mergeRect := Rectangle merging: invalidRects.
+ self reset.
+ invalidRects addLast: mergeRect].
+
+ "add the given rectangle to the damage list"
+ "Note: We make a deep copy of all rectangles added to the damage list,
+ since rectangles in this list may be extended in place."
+ invalidRects addLast:
+ (newRect topLeft truncated corner: newRect bottomRight truncated).
+ !
Item was added:
+ ----- Method: DamageRecorder>>reset (in category 'initialization') -----
+ reset
+ "Clear the damage list."
+
+ invalidRects := OrderedCollection new: 15.
+ totalRepaint := false
+ !
Item was added:
+ ----- Method: DamageRecorder>>updateIsNeeded (in category 'testing') -----
+ updateIsNeeded
+ "Return true if the display needs to be updated."
+
+ ^totalRepaint or: [invalidRects notEmpty]!
Item was added:
+ ----- Method: Debugger class>>morphicOpenOn:context:label:contents:fullView: (in category '*Morphic-opening') -----
+ morphicOpenOn: process context: context label: title contents: contentsStringOrNil fullView: bool
+ "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."
+
+ | errorWasInUIProcess debugger |
+ errorWasInUIProcess := Project current spawnNewProcessIfThisIsUI: process.
+ [Preferences logDebuggerStackToFile
+ ifTrue: [Smalltalk logSqueakError: title inContext: context]] on: Error do: [:ex | ex return: nil].
+ WorldState addDeferredUIMessage: [
+ "schedule debugger in deferred UI message to address redraw
+ problems after opening a debugger e.g. from the testrunner."
+ [
+ debugger := self new process: process controller: nil context: context.
+ bool
+ ifTrue: [debugger openFullNoSuspendLabel: title]
+ ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title].
+ debugger errorWasInUIProcess: errorWasInUIProcess.
+ ] on: Error do: [:ex |
+ self primitiveError:
+ 'Original error: ',
+ title asString, '.
+ Debugger error: ',
+ ([ex description] on: Error do: ['a ', ex class printString]), ':'
+ ]
+ ].
+ process suspend.
+ !
Item was added:
+ ----- Method: Debugger>>morphicResumeProcess: (in category '*Morphic-opening') -----
+ morphicResumeProcess: aTopView
+
+ | processToResume |
+ processToResume := interruptedProcess.
+ interruptedProcess := nil. "Before delete, so release doesn't terminate it"
+ aTopView delete.
+ World displayWorld. "We have to redraw *before* resuming the old process."
+ Smalltalk installLowSpaceWatcher. "restart low space handler"
+
+ savedCursor
+ ifNotNil: [Cursor currentCursor: savedCursor].
+ processToResume isTerminated ifFalse: [
+ errorWasInUIProcess
+ ifTrue: [Project resumeProcess: processToResume]
+ ifFalse: [processToResume resume]].
+ "if old process was terminated, just terminate current one"
+ errorWasInUIProcess == false
+ ifFalse: [Processor terminateActive]!
Item was added:
+ ----- Method: Dictionary>>explorerContents (in category '*Morphic-Explorer') -----
+ explorerContents
+
+ ^self keysSortedSafely replace: [ :key |
+ ObjectExplorerWrapper
+ with: (self at: key)
+ name: (key printString contractTo: 32)
+ model: self ]
+ !
Item was added:
+ ----- Method: Dictionary>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
+ hasContentsInExplorer
+
+ ^self isEmpty not!
Item was added:
+ ----- Method: DisplayScreen>>defaultCanvasClass (in category '*Morphic-blitter defaults') -----
+ defaultCanvasClass
+ "Return the WarpBlt version to use when I am active"
+ ^FormCanvas!
Item was added:
+ ----- Method: DisplayText>>composeForm (in category '*Morphic-Text') -----
+ composeForm
+ "For the TT strings in MVC widgets in a Morphic world such as a progress bar, the form is created by Morphic machinery."
+ | canvas tmpText |
+ Smalltalk isMorphic
+ ifTrue:
+ [tmpText := TextMorph new contentsAsIs: text deepCopy.
+ foreColor ifNotNil: [tmpText text addAttribute: (TextColor color: foreColor)].
+ backColor ifNotNil: [tmpText backgroundColor: backColor].
+ tmpText setTextStyle: textStyle.
+ canvas := FormCanvas on: (Form extent: tmpText extent depth: 32).
+ tmpText drawOn: canvas.
+ form := canvas form.
+ ]
+ ifFalse: [form := self asParagraph asForm]!
Item was added:
+ BorderedMorph subclass: #DoCommandOnceMorph
+ instanceVariableNames: 'target command actionBlock innerArea'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !DoCommandOnceMorph commentStamp: '<historical>' prior: 0!
+ I am used to execute a once-only command. My first use was in loading/saving the current project. In such cases it is necessary to be in another project to do the actual work. So an instance of me is added to a new world/project and that project is entered. I do my stuff (save/load followed by a re-enter of the previous project) and everyone is happy.!
Item was added:
+ ----- Method: DoCommandOnceMorph>>actionBlock: (in category 'as yet unclassified') -----
+ actionBlock: aBlock
+
+ actionBlock := aBlock!
Item was added:
+ ----- Method: DoCommandOnceMorph>>addText: (in category 'as yet unclassified') -----
+ addText: aString
+
+ | t |
+ t := TextMorph new
+ beAllFont: (TextStyle default fontOfSize: 26);
+ contents: aString.
+ self extent: t extent * 3.
+ innerArea := Morph new
+ color: Color white;
+ extent: self extent - (16 at 16);
+ position: self position + (8 at 8);
+ lock.
+ self addMorph: innerArea.
+ self addMorph: (t position: self position + t extent; lock).!
Item was added:
+ ----- Method: DoCommandOnceMorph>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ Color blue!
Item was added:
+ ----- Method: DoCommandOnceMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 8!
Item was added:
+ ----- Method: DoCommandOnceMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+
+ self useRoundedCorners!
Item was added:
+ ----- Method: DoCommandOnceMorph>>openInWorld: (in category 'initialization') -----
+ openInWorld: aWorld
+
+ self position: aWorld topLeft + (aWorld extent - self extent // 2).
+ super openInWorld: aWorld!
Item was added:
+ ----- Method: DoCommandOnceMorph>>step (in category 'stepping and presenter') -----
+ step
+
+ | goForIt |
+
+ actionBlock ifNil: [^self stopStepping].
+ goForIt := actionBlock.
+ actionBlock := nil.
+ goForIt
+ on: ProgressTargetRequestNotification
+ do: [ :ex | ex resume: innerArea]. "in case a save/load progress display needs a home"
+ !
Item was added:
+ ----- Method: DoCommandOnceMorph>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^1
+ !
Item was added:
+ ----- Method: DoCommandOnceMorph>>wantsSteps (in category 'testing') -----
+ wantsSteps
+
+ ^actionBlock notNil
+ !
Item was added:
+ MenuItemMorph subclass: #DockingBarItemMorph
+ instanceVariableNames: 'selectedIcon'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus-DockingBar'!
Item was added:
+ ----- Method: DockingBarItemMorph>>adjacentTo (in category 'selecting') -----
+ adjacentTo
+
+ | roundedCornersOffset |
+ roundedCornersOffset := MenuMorph roundedMenuCorners
+ ifTrue: [Morph preferredCornerRadius negated]
+ ifFalse: [0].
+
+ owner isFloating
+ ifTrue: [^ {self bounds bottomLeft + (roundedCornersOffset @ 4)}].
+ owner isAdheringToTop
+ ifTrue: [^ {self bounds bottomLeft + (roundedCornersOffset @ 4)}].
+ owner isAdheringToLeft
+ ifTrue: [^ {self bounds topRight + (roundedCornersOffset @ 4)}].
+ owner isAdheringToBottom
+ ifTrue: [^ {self bounds topLeft + (roundedCornersOffset @ 4)}].
+ owner isAdheringToRight
+ ifTrue: [^ {self bounds topLeft + (roundedCornersOffset @ -4)}].
+ ^ {self bounds bottomLeft + (roundedCornersOffset @ 5)}!
Item was added:
+ ----- Method: DockingBarItemMorph>>createSubmenu (in category 'private') -----
+ createSubmenu
+
+ ^DockingBarMenuMorph new!
Item was added:
+ ----- Method: DockingBarItemMorph>>createUpdatingSubmenu (in category 'private') -----
+ createUpdatingSubmenu
+
+ ^DockingBarUpdatingMenuMorph new!
Item was added:
+ ----- Method: DockingBarItemMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | stringColor stringBounds |
+ (isSelected and: [ isEnabled ])
+ ifTrue: [
+ aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle.
+ stringColor := color negated ]
+ ifFalse: [ stringColor := color ].
+ stringBounds := bounds.
+ stringBounds := stringBounds left: stringBounds left + self stringMargin.
+ self hasIcon ifTrue: [
+ | iconForm |
+ iconForm := self iconForm.
+ aCanvas
+ translucentImage: iconForm
+ at: stringBounds left @ (self top + (self height - iconForm height // 2)).
+ stringBounds := stringBounds left: stringBounds left + iconForm width + 2 ].
+ stringBounds := stringBounds top: stringBounds top + stringBounds bottom - self fontToUse height // 2.
+ aCanvas
+ drawString: contents
+ in: stringBounds
+ font: self fontToUse
+ color: stringColor!
Item was added:
+ ----- Method: DockingBarItemMorph>>iconForm (in category 'as yet unclassified') -----
+ iconForm
+ "private - answer the form to be used as the icon"
+ ^isEnabled
+ ifTrue: [
+ (isSelected and: [ selectedIcon notNil ])
+ ifTrue: [ selectedIcon ]
+ ifFalse: [ icon ] ]
+ ifFalse: [
+ icon asGrayScale ]!
Item was added:
+ ----- Method: DockingBarItemMorph>>minWidth (in category 'layout') -----
+ minWidth
+
+ | iconWidth |
+ iconWidth := self hasIcon
+ ifTrue: [ self icon width + 2 ]
+ ifFalse: [ 0 ].
+ ^ (self fontToUse widthOfString: contents) + iconWidth + (2 * self stringMargin)!
Item was added:
+ ----- Method: DockingBarItemMorph>>mouseDown: (in category 'events') -----
+ mouseDown: evt
+ "Handle a mouse down event. Menu items get activated when the mouse is over them."
+
+ evt shiftPressed ifTrue: [ ^super mouseDown: evt ]. "enable label editing"
+ isSelected
+ ifTrue: [
+ evt hand newMouseFocus: nil.
+ owner selectItem: nil event: evt. ]
+ ifFalse: [
+ (self containsPoint: evt position) ifFalse: [ self halt ].
+ owner activate: evt. "Redirect to menu for valid transitions"
+ owner selectItem: self event: evt. ]
+ !
Item was added:
+ ----- Method: DockingBarItemMorph>>mouseEnter: (in category 'events') -----
+ mouseEnter: evt
+ "The mouse entered the receiver"
+
+ super mouseEnter: evt.
+ (owner selectedItem notNil and: [ owner selectedItem ~~ self ]) ifTrue: [
+ owner selectItem: self event: evt. ]!
Item was added:
+ ----- Method: DockingBarItemMorph>>mouseLeaveDragging: (in category 'events') -----
+ mouseLeaveDragging: evt !
Item was added:
+ ----- Method: DockingBarItemMorph>>mouseUp: (in category 'events') -----
+ mouseUp: evt
+ "Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
+
+ evt hand mouseFocus == owner ifFalse: [ ^self ].
+ self contentString ifNotNil: [
+ self contents: self contentString withMarkers: true inverse: true.
+ self refreshWorld.
+ (Delay forMilliseconds: 200) wait ].
+ owner rootMenu selectItem: nil event: evt.
+ self invokeWithEvent: evt!
Item was added:
+ ----- Method: DockingBarItemMorph>>select: (in category 'selecting') -----
+ select: evt
+
+ super select: evt.
+ subMenu ifNotNil: [
+ evt hand newKeyboardFocus: subMenu ]!
Item was added:
+ ----- Method: DockingBarItemMorph>>selectedIcon: (in category 'as yet unclassified') -----
+ selectedIcon: aForm
+
+ selectedIcon := aForm!
Item was added:
+ ----- Method: DockingBarItemMorph>>selectionFillStyle (in category 'private') -----
+ selectionFillStyle
+
+ | fill |
+ fill := super selectionFillStyle.
+ fill isColor ifTrue: [ ^fill ].
+ self owner isVertical
+ ifFalse: [ fill direction: 0 @ self height ]
+ ifTrue: [ fill direction: self width @ 0 ].
+ ^fill!
Item was added:
+ ----- Method: DockingBarItemMorph>>stringMargin (in category 'layout') -----
+ stringMargin
+
+ ^Preferences tinyDisplay
+ ifTrue: [ 1 ]
+ ifFalse: [ 6 ]!
Item was added:
+ ----- Method: DockingBarItemMorph>>subMenuMarker (in category 'private') -----
+ subMenuMarker
+
+ self shouldNotImplement!
Item was added:
+ ----- Method: DockingBarItemMorph>>updateLayoutInDockingBar (in category 'private') -----
+ updateLayoutInDockingBar
+
+ owner isVertical
+ ifTrue: [
+ self hResizing: #spaceFill.
+ self vResizing: #shrinkWrap ]
+ ifFalse: [
+ self hResizing: #shrinkWrap.
+ self vResizing: #spaceFill ].
+ self extent: self minWidth @ self minHeight!
Item was added:
+ ----- Method: DockingBarItemMorph>>wantsRoundedCorners (in category 'rounding') -----
+ wantsRoundedCorners
+
+ ^false!
Item was added:
+ MenuMorph subclass: #DockingBarMenuMorph
+ instanceVariableNames: 'activatorDockingBar'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus-DockingBar'!
Item was added:
+ ----- Method: DockingBarMenuMorph>>activatedFromDockingBar: (in category 'as yet unclassified') -----
+ activatedFromDockingBar: aDockingBar
+
+ activatorDockingBar := aDockingBar!
Item was added:
+ ----- Method: DockingBarMenuMorph>>handleCRStroke: (in category 'keystroke helpers') -----
+ handleCRStroke: evt
+
+ evt keyValue = 13 ifFalse: [ ^false ].
+ selectedItem ifNotNil: [ selectedItem invokeWithEvent: evt ].
+ ^true!
Item was added:
+ ----- Method: DockingBarMenuMorph>>handleLeftStroke: (in category 'keystroke helpers') -----
+ handleLeftStroke: evt
+
+ 28 = evt keyValue ifFalse: [ ^false ].
+ (self stepIntoSubmenu: evt) ifFalse: [
+ self deactivate: evt.
+ activatorDockingBar moveSelectionDown: -1 event: evt ].
+ ^true!
Item was added:
+ ----- Method: DockingBarMenuMorph>>handleRightStroke: (in category 'keystroke helpers') -----
+ handleRightStroke: evt
+
+ 29 = evt keyValue ifFalse: [ ^false ].
+ (self stepIntoSubmenu: evt) ifFalse: [
+ self deactivate: evt.
+ activatorDockingBar moveSelectionDown: 1 event: evt ].
+ ^true!
Item was added:
+ ----- Method: DockingBarMenuMorph>>roundedCorners (in category 'rounding') -----
+ roundedCorners
+ "Return a list of those corners to round"
+ activatorDockingBar isFloating
+ ifTrue: [^ #(2 3 )].
+ activatorDockingBar isAdheringToTop
+ ifTrue: [^ #(2 3 )].
+ activatorDockingBar isAdheringToBottom
+ ifTrue: [^ #(1 4 )].
+ activatorDockingBar isAdheringToLeft
+ ifTrue: [^ #(3 4 )].
+ activatorDockingBar isAdheringToRight
+ ifTrue: [^ #(1 2 )]!
Item was added:
+ ----- Method: DockingBarMenuMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ activatorDockingBar := activatorDockingBar. "Weakly copied"
+ !
Item was added:
+ AlignmentMorph subclass: #DockingBarMorph
+ instanceVariableNames: 'originalColor gradientRamp fillsOwner avoidVisibleBordersAtEdge autoGradient selectedItem activeSubMenu oldKeyboardFocus oldMouseFocus'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus-DockingBar'!
Item was added:
+ ----- Method: DockingBarMorph class>>defaultNameStemForInstances (in category 'scripting') -----
+ defaultNameStemForInstances
+ ^ 'DockingBar'!
Item was added:
+ ----- Method: DockingBarMorph class>>example1 (in category 'samples') -----
+ example1
+ "
+ DockingBarMorph example1.
+
+ (Color lightBlue wheel: 4) do:[:c | DockingBarMorph example1
+ color: c; borderColor: c twiceDarker].
+
+ World deleteDockingBars.
+ "
+ | instance |
+ instance := DockingBarMorph new.
+ ""
+ instance addSpace: 10.
+ instance
+ addMorphBack: (ClockMorph new show24hr: true).
+ instance addSpacer.
+ instance
+ addMorphBack: (ClockMorph new show24hr: true).
+ instance addSpace: 10.
+ ""
+ instance adhereToTop.
+ ""
+ instance autoGradient: true.
+ instance layoutInset: 10.
+ ""
+ ^ instance openInWorld!
Item was added:
+ ----- Method: DockingBarMorph class>>example2 (in category 'samples') -----
+ example2
+ "
+ DockingBarMorph example2.
+ World deleteDockingBars.
+ "
+ | menu |
+ menu := DockingBarMorph new.
+ ""
+ menu addSpace: 10.
+ menu
+ add: 'Squeak'
+ icon: MenuIcons smallConfigurationIcon
+ subMenu: self squeakMenu.
+ menu
+ add: 'Configuration'
+ icon: MenuIcons smallWindowIcon
+ subMenu: self squeakMenu.
+ menu addSpace: 10.
+ menu addLine.
+ menu addSpace: 10.
+ menu
+ addMorphBack: (ImageMorph new image: MenuIcons smallBackIcon).
+ menu addSpace: 10.
+ menu
+ addMorphBack: (ImageMorph new image: MenuIcons smallForwardIcon).
+ menu addSpace: 10.
+ menu addLine.
+ menu addSpacer.
+ ""
+ menu addMorphBack: ProjectNavigationMorph new speakerIcon.
+ ""
+ menu addSpace: 10.
+ menu
+ addMorphBack: (ClockMorph new show24hr: true).
+ menu addSpace: 10.
+ ""
+ menu adhereToTop.
+ ""
+ menu autoGradient: true.
+ ""
+ ^ menu openInWorld!
Item was added:
+ ----- Method: DockingBarMorph class>>example3 (in category 'samples') -----
+ example3
+ "
+ DockingBarMorph example3.
+ World deleteDockingBars.
+ "
+ (Color lightBlue wheel: 4)
+ with: #(#top #bottom #left #right )
+ do: [:col :edge |
+ | instance |
+ instance := DockingBarMorph example1.
+ instance adhereTo: edge.
+ instance color: col.
+ instance borderColor: col twiceDarker]!
Item was added:
+ ----- Method: DockingBarMorph class>>squeakMenu (in category 'samples') -----
+ squeakMenu
+ | menu |
+ menu := MenuMorph new defaultTarget: self.
+ menu
+ add: 'Hello'
+ target: self
+ selector: #inform:
+ argument: 'Hello World!!'.
+ menu
+ add: 'Long Hello'
+ target: self
+ selector: #inform:
+ argument: 'Helloooo World!!'.
+ menu
+ add: 'A very long Hello'
+ target: self
+ selector: #inform:
+ argument: 'Hellooooooooooooooo World!!'.
+ menu
+ add: 'An incredible long Hello'
+ target: self
+ selector: #inform:
+ argument: 'Hellooooooooooooooooooooooo World!!'.
+ ^ menu!
Item was added:
+ ----- Method: DockingBarMorph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
+ aboutToBeGrabbedBy: aHand
+ "The morph is about to be grabbed, make it float"
+ self beFloating.
+ self updateBounds.
+ self updateColor.
+ (self bounds containsPoint: aHand position)
+ ifFalse: [self center: aHand position].
+ self owner restoreFlapsDisplay!
Item was added:
+ ----- Method: DockingBarMorph>>activate: (in category 'events') -----
+ activate: evt
+ "Receiver should be activated; e.g., so that control passes
+ correctly."
+
+ oldKeyboardFocus := evt hand keyboardFocus.
+ self oldMouseFocus: evt hand mouseFocus.
+ evt hand
+ newKeyboardFocus: self;
+ newMouseFocus: self.
+ self ensureSelectedItem: evt!
Item was added:
+ ----- Method: DockingBarMorph>>activeSubmenu: (in category 'control') -----
+ activeSubmenu: aSubmenu
+ activeSubMenu isNil
+ ifFalse: [activeSubMenu delete].
+ activeSubMenu := aSubmenu.
+ aSubmenu isNil
+ ifTrue: [^ self].
+ activeSubMenu updateMenu.
+ activeSubMenu selectItem: nil event: nil.
+ MenuIcons decorateMenu: activeSubMenu.
+ activeSubMenu
+ activatedFromDockingBar: self;
+ beSticky;
+ resistsRemoval: true;
+ removeMatchString!
Item was added:
+ ----- Method: DockingBarMorph>>add:icon:help:subMenu: (in category 'construction') -----
+ add: wordingString icon: aForm help: helpString subMenu: aMenuMorph
+ "Append the given submenu with the given label."
+ | item |
+ item := DockingBarItemMorph new.
+ item contents: wordingString.
+ item subMenu: aMenuMorph.
+ item icon: aForm.
+ helpString isNil
+ ifFalse: [item setBalloonText: helpString].
+ self addMorphBack: item!
Item was added:
+ ----- Method: DockingBarMorph>>add:icon:selectedIcon:help:subMenu: (in category 'construction') -----
+ add: wordingString icon: aForm selectedIcon: anotherForm help: helpString subMenu: aMenuMorph
+ "Append the given submenu with the given label."
+ | item |
+ item := DockingBarItemMorph new
+ contents: wordingString;
+ subMenu: aMenuMorph;
+ icon: aForm;
+ selectedIcon: anotherForm.
+ helpString isNil ifFalse: [
+ item setBalloonText: helpString ].
+ self addMorphBack: item!
Item was added:
+ ----- Method: DockingBarMorph>>add:icon:subMenu: (in category 'construction') -----
+ add: wordingString icon: aForm subMenu: aMenuMorph
+ "Append the given submenu with the given label."
+ ^ self add: wordingString icon: aForm help: nil subMenu: aMenuMorph !
Item was added:
+ ----- Method: DockingBarMorph>>add:subMenu: (in category 'construction') -----
+ add: aString subMenu: aMenuMorph
+ "Append the given submenu with the given label."
+ self add: aString icon: nil subMenu: aMenuMorph !
Item was added:
+ ----- Method: DockingBarMorph>>addBlankIconsIfNecessary: (in category 'accessing') -----
+ addBlankIconsIfNecessary: anIcon
+ "If any of my items have an icon, ensure that all do by using
+ anIcon for those that don't"
+ self items
+ reject: [:each | each hasIconOrMarker]
+ thenDo: [:each | each icon: anIcon]!
Item was added:
+ ----- Method: DockingBarMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu hand: aHandMorph
+ "Populate aMenu with appropriate menu items for a
+ yellow-button (context menu) click."
+ super addCustomMenuItems: aMenu hand: aHandMorph.
+ ""
+ aMenu addLine.
+ aMenu addUpdating: #autoGradientString action: #toggleAutoGradient.
+ self isFloating
+ ifFalse: [""
+ aMenu addUpdating: #fillsOwnerString action: #toggleFillsOwner.
+ aMenu addUpdating: #avoidVisibleBordersAtEdgeString action: #toggleAvoidVisibleBordersAtEdge]!
Item was added:
+ ----- Method: DockingBarMorph>>addDefaultSpace (in category 'construction') -----
+ addDefaultSpace
+ "Add a new space of the given size to the receiver."
+ ^ self addSpace: (Preferences tinyDisplay ifFalse:[10] ifTrue:[3])!
Item was added:
+ ----- Method: DockingBarMorph>>addItem: (in category 'construction') -----
+ addItem: aBlock
+ | item |
+ item := DockingBarItemMorph new.
+ aBlock value: item.
+ self addMorphBack: item!
Item was added:
+ ----- Method: DockingBarMorph>>addLine (in category 'construction') -----
+ addLine
+ "Append a divider line to this menu. Suppress duplicate lines."
+
+ submorphs isEmpty ifTrue: [^ self].
+ (self lastSubmorph isKindOf: MenuLineMorph)
+ ifFalse: [self addMorphBack: MenuLineMorph new].
+ !
Item was added:
+ ----- Method: DockingBarMorph>>addSpace: (in category 'construction') -----
+ addSpace: sizePointOrNumber
+ "Add a new space of the given size to the receiver."
+ | space |
+ space := RectangleMorph new.
+ space extent: sizePointOrNumber asPoint.
+ space color: Color transparent.
+ space borderWidth: 0.
+ self addMorphBack: space!
Item was added:
+ ----- Method: DockingBarMorph>>addSpacer (in category 'construction') -----
+ addSpacer
+ "Add a new spacer to the receiver.
+
+ Spacer are objects that try to use as much space as they can"
+ self
+ addMorphBack: (AlignmentMorph newSpacer: Color transparent)!
Item was added:
+ ----- Method: DockingBarMorph>>adhereTo: (in category 'private - accessing') -----
+ adhereTo: edgeSymbol
+ "Private - Instruct the receiver to adhere to the given edge.
+
+ Options: #left #top #right #bottom or #none"
+ ""
+ (#(#left #top #right #bottom #none ) includes: edgeSymbol)
+ ifFalse: [^ self error: 'invalid option'].
+ ""
+ self setToAdhereToEdge: edgeSymbol.
+ self updateLayoutProperties.
+ self updateColor!
Item was added:
+ ----- Method: DockingBarMorph>>adhereToBottom (in category 'accessing') -----
+ adhereToBottom
+ "Instract the receiver to adhere to bottom"
+ self adhereTo:#bottom!
Item was added:
+ ----- Method: DockingBarMorph>>adhereToLeft (in category 'accessing') -----
+ adhereToLeft
+ "Instract the receiver to adhere to left"
+ self adhereTo: #left!
Item was added:
+ ----- Method: DockingBarMorph>>adhereToRight (in category 'accessing') -----
+ adhereToRight
+ "Instract the receiver to adhere to right"
+ self adhereTo: #right!
Item was added:
+ ----- Method: DockingBarMorph>>adhereToTop (in category 'accessing') -----
+ adhereToTop
+ "Instract the receiver to adhere to top"
+ self adhereTo: #top!
Item was added:
+ ----- Method: DockingBarMorph>>autoGradient (in category 'accessing') -----
+ autoGradient
+ "Answer if the receiver is in autoGradient mode"
+ ^ autoGradient!
Item was added:
+ ----- Method: DockingBarMorph>>autoGradient: (in category 'accessing') -----
+ autoGradient: aBoolean
+ "Instruct the receiver to fill the owner or not"
+ autoGradient := aBoolean.
+ self updateColor!
Item was added:
+ ----- Method: DockingBarMorph>>autoGradientString (in category 'menu') -----
+ autoGradientString
+ "Answer the string to be shown in a menu to represent the
+ 'resistsRemoval' status"
+ ^ (self autoGradient
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'auto gradient' translated!
Item was added:
+ ----- Method: DockingBarMorph>>avoidVisibleBordersAtEdge (in category 'accessing') -----
+ avoidVisibleBordersAtEdge
+ "Answer if the receiver is in avoidVisibleBordersAtEdge mode"
+ ^ avoidVisibleBordersAtEdge!
Item was added:
+ ----- Method: DockingBarMorph>>avoidVisibleBordersAtEdge: (in category 'accessing') -----
+ avoidVisibleBordersAtEdge: aBoolean
+ "Instruct the receiver to avoid showing the borders at edge"
+ avoidVisibleBordersAtEdge := aBoolean.
+ self updateLayoutProperties.!
Item was added:
+ ----- Method: DockingBarMorph>>avoidVisibleBordersAtEdgeString (in category 'menu') -----
+ avoidVisibleBordersAtEdgeString
+ "Answer the string to be shown in a menu to represent the
+ 'resistsRemoval' status"
+ ^ (self avoidVisibleBordersAtEdge
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'avoid visible borders at edge' translated!
Item was added:
+ ----- Method: DockingBarMorph>>beFloating (in category 'accessing') -----
+ beFloating
+ "Instract the receiver to be floating"
+ self adhereTo: #none!
Item was added:
+ ----- Method: DockingBarMorph>>blueButtonDown: (in category 'meta-actions') -----
+ blueButtonDown: anEvent
+ "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on
+ Windows and Unix) allow a mouse-sensitive morph to be
+ moved or bring up a halo for the morph."
+ "In NoviceMode we don't want halos"
+
+ Preferences noviceMode
+ ifFalse: [super blueButtonDown: anEvent]
+ !
Item was added:
+ ----- Method: DockingBarMorph>>color: (in category 'accessing') -----
+ color: aColor
+ "Set the receiver's color."
+ super color: aColor.
+ originalColor := aColor asColor.
+ ""
+ self updateColor!
Item was added:
+ ----- Method: DockingBarMorph>>deactivate: (in category 'events') -----
+ deactivate: evt
+
+ self selectItem: nil event: evt.
+ evt hand
+ newKeyboardFocus: self oldKeyboardFocus;
+ newMouseFocus: self oldMouseFocus!
Item was added:
+ ----- Method: DockingBarMorph>>delete (in category 'submorphs-add/remove') -----
+ delete
+
+ ActiveHand removeKeyboardListener: self.
+ activeSubMenu
+ ifNotNil: [activeSubMenu delete].
+ ^ super delete!
Item was added:
+ ----- Method: DockingBarMorph>>deleteIfPopUp: (in category 'control') -----
+ deleteIfPopUp: evt
+
+ evt ifNotNil: [
+ evt hand releaseMouseFocus: self ]!
Item was added:
+ ----- Method: DockingBarMorph>>edgeToAdhereTo (in category 'private - accessing') -----
+ edgeToAdhereTo
+ "private - answer the edge where the receiver is adhering to"
+ ^ self
+ valueOfProperty: #edgeToAdhereTo
+ ifAbsent: [#none]!
Item was added:
+ ----- Method: DockingBarMorph>>ensureSelectedItem: (in category 'events') -----
+ ensureSelectedItem: evt
+
+ self selectedItem ifNil: [
+ self
+ selectItem: (
+ self submorphs
+ detect: [ :each | each isKindOf: DockingBarItemMorph ]
+ ifNone: [ ^self ])
+ event: evt ]!
Item was added:
+ ----- Method: DockingBarMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "change the receiver's extent"
+ (bounds extent closeTo: aPoint) ifTrue: [^ self].
+ super extent: aPoint.
+ self updateColor!
Item was added:
+ ----- Method: DockingBarMorph>>fillsOwner (in category 'accessing') -----
+ fillsOwner
+ "Answer if the receiver is in fillOwner mode"
+ ^ fillsOwner!
Item was added:
+ ----- Method: DockingBarMorph>>fillsOwner: (in category 'accessing') -----
+ fillsOwner: aBoolean
+ "Instruct the receiver to fill the owner or not"
+ fillsOwner := aBoolean.
+ self updateLayoutProperties!
Item was added:
+ ----- Method: DockingBarMorph>>fillsOwnerString (in category 'menu') -----
+ fillsOwnerString
+ "Answer the string to be shown in a menu to represent the
+ 'resistsRemoval' status"
+ ^ (self fillsOwner
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'fills owner' translated
+ !
Item was added:
+ ----- Method: DockingBarMorph>>gradientRamp (in category 'private - layout') -----
+ gradientRamp
+ ^ gradientRamp ifNil:[{0.0 -> originalColor muchLighter. 1.0 -> originalColor twiceDarker}]!
Item was added:
+ ----- Method: DockingBarMorph>>gradientRamp: (in category 'private - layout') -----
+ gradientRamp: colorRamp
+ gradientRamp := colorRamp.
+ ""
+ self updateColor!
Item was added:
+ ----- Method: DockingBarMorph>>handleFocusEvent: (in category 'events-processing') -----
+ handleFocusEvent: evt
+ "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children."
+
+ (evt isMouse and:[ evt isMouseUp ]) ifTrue:[^ self].
+
+ self processEvent: evt.
+
+ "Need to handle keyboard input if we have the focus."
+ evt isKeyboard ifTrue: [^ self handleEvent: evt].
+
+ "We need to handle button clicks outside and transitions to local popUps so throw away everything else"
+ (evt isMouseOver or:[evt isMouse not]) ifTrue:[^self].
+ "What remains are mouse buttons and moves"
+ evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means"
+ "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first."
+ selectedItem ifNotNil:[(selectedItem activateSubmenu: evt) ifTrue:[^self]].
+ !
Item was added:
+ ----- Method: DockingBarMorph>>handleListenEvent: (in category 'events-processing') -----
+ handleListenEvent: anEvent
+ " I am registered as a keyboardListener of the ActiveHand,
+ watching for ctrl-<n> keystrokes, and upon them if I have
+ an nth menu item, I'll activate myself and select it. "
+
+ (anEvent controlKeyPressed and: [
+ anEvent keyValue
+ between: 48 " $0 asciiValue "
+ and: 55 " $7 asciiValue " ]) ifTrue: [
+ | index itemToSelect |
+ index := anEvent keyValue - 48.
+ itemToSelect := (submorphs select: [ :each |
+ each isKindOf: DockingBarItemMorph ])
+ at: index
+ ifAbsent: [
+ ^self searchBarMorph ifNotNil: [ :morph |
+ morph model activate: anEvent in: morph ] ].
+ self activate: anEvent.
+ self
+ selectItem: itemToSelect
+ event: anEvent ]!
Item was added:
+ ----- Method: DockingBarMorph>>handlesKeyboard: (in category 'events-processing') -----
+ handlesKeyboard: evt
+
+ ^true!
Item was added:
+ ----- Method: DockingBarMorph>>initialize (in category 'initialize-release') -----
+ initialize
+ "initialize the receiver"
+ super initialize.
+ selectedItem := nil.
+ activeSubMenu := nil.
+ fillsOwner := true.
+ avoidVisibleBordersAtEdge := true.
+ autoGradient := MenuMorph gradientMenu.
+ self
+ setDefaultParameters ;
+ beFloating ;
+ beSticky ;
+ layoutInset: 0 ;
+ dropEnabled: true.
+ Project current world activeHand addKeyboardListener: self!
Item was added:
+ ----- Method: DockingBarMorph>>isAdheringToBottom (in category 'accessing') -----
+ isAdheringToBottom
+ "Answer true if the receiver is adhering to bottom"
+ ^ self edgeToAdhereTo == #bottom!
Item was added:
+ ----- Method: DockingBarMorph>>isAdheringToLeft (in category 'accessing') -----
+ isAdheringToLeft
+ "Answer true if the receiver is adhering to left"
+ ^ self edgeToAdhereTo == #left!
Item was added:
+ ----- Method: DockingBarMorph>>isAdheringToRight (in category 'accessing') -----
+ isAdheringToRight
+ "Answer true if the receiver is adhering to right"
+ ^ self edgeToAdhereTo == #right!
Item was added:
+ ----- Method: DockingBarMorph>>isAdheringToTop (in category 'accessing') -----
+ isAdheringToTop
+ "Answer true if the receiver is adhering to top"
+ ^ self edgeToAdhereTo == #top!
Item was added:
+ ----- Method: DockingBarMorph>>isDockingBar (in category 'testing') -----
+ isDockingBar
+ "Return true if the receiver is a docking bar"
+ ^ true!
Item was added:
+ ----- Method: DockingBarMorph>>isFloating (in category 'accessing') -----
+ isFloating
+ "Answer true if the receiver has a float layout"
+ ^ self isHorizontal not
+ and: [self isVertical not]!
Item was added:
+ ----- Method: DockingBarMorph>>isHorizontal (in category 'accessing') -----
+ isHorizontal
+ "Answer true if the receiver has a horizontal layout"
+ ^ self isAdheringToTop
+ or: [self isAdheringToBottom]!
Item was added:
+ ----- Method: DockingBarMorph>>isSticky (in category 'accessing') -----
+ isSticky
+ "answer whether the receiver is Sticky"
+ ^ Preferences noviceMode
+ or: [super isSticky] !
Item was added:
+ ----- Method: DockingBarMorph>>isVertical (in category 'accessing') -----
+ isVertical
+ "Answer true if the receiver has a vertical layout"
+ ^ self isAdheringToLeft
+ or: [self isAdheringToRight]
+ !
Item was added:
+ ----- Method: DockingBarMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: aMorph event: anEvent
+ | ownerBounds leftRegion droppedPosition rightRegion topRegion bottomRegion |
+ super justDroppedInto: aMorph event: anEvent.
+ ""
+ self owner isNil
+ ifTrue: [^ self].
+ ""
+ ownerBounds := aMorph bounds.
+ topRegion := ownerBounds bottom: ownerBounds top + (ownerBounds height // 5).
+ bottomRegion := ownerBounds top: ownerBounds bottom - (ownerBounds height // 5).
+ ""
+ leftRegion := ownerBounds right: ownerBounds left + (ownerBounds width // 5).
+ leftRegion := leftRegion top: topRegion bottom.
+ leftRegion := leftRegion bottom: bottomRegion top.
+ ""
+ rightRegion := ownerBounds left: ownerBounds right - (ownerBounds width // 5).
+ rightRegion := rightRegion top: topRegion bottom.
+ rightRegion := rightRegion bottom: bottomRegion top.
+ ""
+ droppedPosition := anEvent position.
+ (topRegion containsPoint: droppedPosition)
+ ifTrue: [
+ ^ self adhereToTop].
+ (bottomRegion containsPoint: droppedPosition)
+ ifTrue: [
+ ^ self adhereToBottom].
+ (leftRegion containsPoint: droppedPosition)
+ ifTrue: [
+ ^ self adhereToLeft].
+ (rightRegion containsPoint: droppedPosition)
+ ifTrue: [
+ ^ self adhereToRight].
+ ""
+ self beFloating!
Item was added:
+ ----- Method: DockingBarMorph>>keyStroke: (in category 'events-processing') -----
+ keyStroke: evt
+
+ | asc |
+ asc := evt keyCharacter asciiValue.
+ asc = 27 ifTrue: [ "escape key"
+ ^self deactivate: evt ].
+ asc = self selectSubmenuKey ifTrue: [
+ self ensureSelectedItem: evt.
+ self selectedItem subMenu ifNotNil: [ :subMenu |
+ subMenu items ifNotEmpty: [
+ subMenu activate: evt.
+ ^subMenu moveSelectionDown: 1 event: evt ] ] ].
+ asc = self previousKey ifTrue: [ ^self moveSelectionDown: -1 event: evt ].
+ asc = self nextKey ifTrue: [ ^self moveSelectionDown: 1 event: evt ].
+ selectedItem ifNotNil: [
+ selectedItem subMenu ifNotNil: [ :subMenu |
+ " If we didn't handle the keystroke, pass the keyboard focus
+ to the open submenu. "
+ evt hand newKeyboardFocus: subMenu.
+ subMenu keyStroke: evt ] ]!
Item was added:
+ ----- Method: DockingBarMorph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+ "helpful for insuring some morphs always appear in front of or
+ behind others. smaller numbers are in front"
+ ^ 11!
Item was added:
+ ----- Method: DockingBarMorph>>mouseDown: (in category 'events-processing') -----
+ mouseDown: evt
+
+ (self fullContainsPoint: evt position) ifFalse: [
+ self selectItem: nil event: evt.
+ evt hand releaseMouseFocus: self ]!
Item was added:
+ ----- Method: DockingBarMorph>>moveSelectionDown:event: (in category 'control') -----
+ moveSelectionDown: direction event: evt
+ "Move the current selection up or down by one, presumably under keyboard control.
+ direction = +/-1"
+
+ | index |
+ index := (submorphs indexOf: selectedItem ifAbsent: [1-direction]) + direction.
+ submorphs do: "Ensure finite"
+ [:unused | | m |
+ m := submorphs atWrap: index.
+ ((m isKindOf: DockingBarItemMorph) and: [m isEnabled]) ifTrue:
+ [^ self selectItem: m event: evt].
+ "Keep looking for an enabled item"
+ index := index + direction sign].
+ ^ self selectItem: nil event: evt!
Item was added:
+ ----- Method: DockingBarMorph>>nextKey (in category 'events-processing') -----
+ nextKey
+
+ self isHorizontal ifTrue: [ ^29 " right arrow" ].
+ self isVertical ifTrue: [ ^31 " down arrow " ]!
Item was added:
+ ----- Method: DockingBarMorph>>noteNewOwner: (in category 'submorphs-accessing') -----
+ noteNewOwner: aMorph
+ "I have just been added as a submorph of aMorph"
+ super noteNewOwner: aMorph.
+
+ self submorphs
+ do: [:each | each adjustLayoutBounds].
+ !
Item was added:
+ ----- Method: DockingBarMorph>>oldKeyboardFocus (in category 'events') -----
+ oldKeyboardFocus
+
+ oldKeyboardFocus = self
+ ifTrue: [ ^nil ]
+ ifFalse: [ ^oldKeyboardFocus ]!
Item was added:
+ ----- Method: DockingBarMorph>>oldMouseFocus (in category 'events') -----
+ oldMouseFocus
+
+ oldMouseFocus = self
+ ifTrue: [ ^nil ]
+ ifFalse: [ ^oldMouseFocus ]!
Item was added:
+ ----- Method: DockingBarMorph>>oldMouseFocus: (in category 'events') -----
+ oldMouseFocus: aMorph
+
+ (self submorphs includes: aMorph)
+ ifFalse: [ oldMouseFocus := aMorph ]
+ ifTrue: [ oldMouseFocus := nil ]
+ !
Item was added:
+ ----- Method: DockingBarMorph>>ownerChanged (in category 'change reporting') -----
+ ownerChanged
+ "The receiver's owner has changed its layout. "
+ self updateBounds.
+ ^ super ownerChanged!
Item was added:
+ ----- Method: DockingBarMorph>>predominantDockingBarsOfChastes: (in category 'private - accessing') -----
+ predominantDockingBarsOfChastes: predominantChastes
+ "Private - Answer a collection of the docking bar of my owner
+ that are predominant to the receiver.
+
+ By 'predominant' we mean docking bar that have the right to
+ get a position before the receiver.
+
+ The predominance of individual living in the same chaste is
+ determinated by the arrival order.
+ "
+ | allDockingBars byChaste byArrival |
+ (self owner isNil
+ or: [self owner isHandMorph])
+ ifTrue: [^ #()].
+ ""
+ allDockingBars := self owner dockingBars.
+ ""
+ byChaste := allDockingBars
+ select: [:each | predominantChastes includes: each edgeToAdhereTo].
+ ""
+ (predominantChastes includes: self edgeToAdhereTo)
+ ifFalse: [^ byChaste].
+ ""
+ byChaste := byChaste
+ reject: [:each | each edgeToAdhereTo = self edgeToAdhereTo].
+ ""
+ byArrival := allDockingBars
+ select: [:each | each edgeToAdhereTo = self edgeToAdhereTo].
+
+ byArrival := byArrival copyAfter: self.
+ ""
+ ^ byChaste , byArrival!
Item was added:
+ ----- Method: DockingBarMorph>>previousKey (in category 'events-processing') -----
+ previousKey
+
+ self isHorizontal ifTrue: [ ^28 "left arrow" ].
+ self isVertical ifTrue: [ ^30 "up arrow " ]!
Item was added:
+ ----- Method: DockingBarMorph>>release (in category 'initialize-release') -----
+ release
+ activeSubMenu := selectedItem := oldKeyboardFocus := oldMouseFocus := nil!
Item was added:
+ ----- Method: DockingBarMorph>>resistsRemoval (in category 'accessing') -----
+ resistsRemoval
+ "Answer whether the receiver is marked as resisting removal"
+ ^ Preferences noviceMode
+ or: [super resistsRemoval]!
Item was added:
+ ----- Method: DockingBarMorph>>rootMenu (in category 'accessing') -----
+ rootMenu
+ ^ self!
Item was added:
+ ----- Method: DockingBarMorph>>roundedCorners (in category 'rounding') -----
+ roundedCorners
+ "Return a list of those corners to round"
+ self isAdheringToTop
+ ifTrue: [^ #(2 3 )].
+ self isAdheringToBottom
+ ifTrue: [^ #(1 4 )].
+ self isAdheringToLeft
+ ifTrue: [^ #(3 4 )].
+ self isAdheringToRight
+ ifTrue: [^ #(1 2 )].
+ ^ #(1 2 3 4 )!
Item was added:
+ ----- Method: DockingBarMorph>>searchBarMorph (in category 'events-processing') -----
+ searchBarMorph
+
+ ^self submorphs detect: [ :each | each knownName = #searchBar ] ifNone: [ nil ]!
Item was added:
+ ----- Method: DockingBarMorph>>selectItem:event: (in category 'control') -----
+ selectItem: aMenuItem event: anEvent
+ selectedItem
+ ifNotNil: [selectedItem deselect: anEvent].
+ selectedItem := aMenuItem.
+ selectedItem
+ ifNotNil: [selectedItem select: anEvent]!
Item was added:
+ ----- Method: DockingBarMorph>>selectSubmenuKey (in category 'events-processing') -----
+ selectSubmenuKey
+
+ self isAdheringToTop ifTrue: [ ^31 ].
+ self isAdheringToRight ifTrue: [ ^28 ].
+ self isAdheringToLeft ifTrue: [ ^29 ].
+ self isAdheringToBottom ifTrue: [ 30 ].
+ ^31!
Item was added:
+ ----- Method: DockingBarMorph>>selectedItem (in category 'private') -----
+ selectedItem
+
+ (selectedItem notNil and: [
+ selectedItem isSelected ]) ifTrue: [
+ ^selectedItem ].
+ ^ nil!
Item was added:
+ ----- Method: DockingBarMorph>>setDefaultParameters (in category 'initialize-release') -----
+ setDefaultParameters
+ "private - set the default parameter using Preferences as the inspiration source"
+ | colorFromMenu worldColor menuColor menuBorderColor |
+ colorFromMenu := Preferences menuColorFromWorld
+ and: [Display depth > 4
+ and: [(worldColor := self currentWorld color) isColor]].
+ ""
+ menuColor := colorFromMenu
+ ifTrue: [worldColor luminance > 0.7
+ ifTrue: [worldColor mixed: 0.85 with: Color black]
+ ifFalse: [worldColor mixed: 0.4 with: Color white]]
+ ifFalse: [Preferences menuColor].
+ ""
+ menuBorderColor := Preferences menuAppearance3d
+ ifTrue: [#raised]
+ ifFalse: [colorFromMenu
+ ifTrue: [worldColor muchDarker]
+ ifFalse: [Preferences menuBorderColor]].
+ ""
+ self
+ setColor: menuColor
+ borderWidth: Preferences menuBorderWidth
+ borderColor: menuBorderColor!
Item was added:
+ ----- Method: DockingBarMorph>>snapToEdgeIfAppropriate (in category 'menus') -----
+ snapToEdgeIfAppropriate
+ (self owner isNil
+ or: [self owner isHandMorph])
+ ifTrue: [^ self].
+ ""
+ self updateBounds!
Item was added:
+ ----- Method: DockingBarMorph>>stayUp (in category 'accessing') -----
+ stayUp
+ ^ false!
Item was added:
+ ----- Method: DockingBarMorph>>toggleAutoGradient (in category 'menu') -----
+ toggleAutoGradient
+ self autoGradient: self autoGradient not!
Item was added:
+ ----- Method: DockingBarMorph>>toggleAvoidVisibleBordersAtEdge (in category 'menu') -----
+ toggleAvoidVisibleBordersAtEdge
+ self avoidVisibleBordersAtEdge: self avoidVisibleBordersAtEdge not!
Item was added:
+ ----- Method: DockingBarMorph>>toggleFillsOwner (in category 'menu') -----
+ toggleFillsOwner
+ self fillsOwner: self fillsOwner not!
Item was added:
+ ----- Method: DockingBarMorph>>updateBounds (in category 'private - layout') -----
+ updateBounds
+ "private - update the receiver's bounds"
+ self updateExtent.
+ self isFloating
+ ifFalse: [self updatePosition]!
Item was added:
+ ----- Method: DockingBarMorph>>updateColor (in category 'private - layout') -----
+ updateColor
+ "private - update the receiver's color"
+ | fill |
+ self autoGradient ifFalse: [
+ self color ~= originalColor ifTrue: [self color: originalColor].
+ ^ self].
+ ""
+ fill := GradientFillStyle ramp: self gradientRamp.
+ ""
+ fill origin: self topLeft.
+ self isVertical
+ ifTrue: [fill direction: self width @ 0]
+ ifFalse: [fill direction: 0 @ self height].
+ ""
+ self fillStyle: fill!
Item was added:
+ ----- Method: DockingBarMorph>>updateExtent (in category 'private - layout') -----
+ updateExtent
+ "private - update the receiver's extent"
+ | margin |
+ self fullBounds.
+ self fillsOwner
+ ifFalse: [^ self].
+ ""
+ margin := self avoidVisibleBordersAtEdge
+ ifTrue: [self borderWidth * 2]
+ ifFalse: [0].""
+ self isHorizontal
+ ifTrue: [self width: self owner width + margin].""
+ self isVertical
+ ifTrue: [| usedHeight |
+ usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top #bottom ).
+ self height: self owner height + margin - usedHeight]!
Item was added:
+ ----- Method: DockingBarMorph>>updateLayoutProperties (in category 'private - layout') -----
+ updateLayoutProperties
+ "private - update the layout properties based on adhering,
+ fillsOwner and avoidVisibleBordersAtEdge preferencs"
+ ""
+ (self isHorizontal
+ or: [self isFloating])
+ ifTrue: [self listDirection: #leftToRight]
+ ifFalse: [self listDirection: #topToBottom].
+ ""
+ self hResizing: #shrinkWrap.
+ self vResizing: #shrinkWrap.
+ self fillsOwner
+ ifTrue: [""
+ self isHorizontal
+ ifTrue: [self hResizing: #spaceFill].
+ self isVertical
+ ifTrue: [self vResizing: #spaceFill]].
+ !
Item was added:
+ ----- Method: DockingBarMorph>>updatePosition (in category 'private - layout') -----
+ updatePosition
+ "private - update the receiver's position"
+ | edgeSymbol margin |
+ edgeSymbol := self edgeToAdhereTo.
+ self
+ perform: (edgeSymbol , ':') asSymbol
+ with: (self owner perform: edgeSymbol).
+ ""
+ margin := self avoidVisibleBordersAtEdge
+ ifTrue: [self borderWidth asPoint]
+ ifFalse: [0 asPoint].
+ ""
+ self isAdheringToTop
+ ifTrue: [| usedHeight |
+ usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ).
+ self topLeft: self owner topLeft - margin + (0 @ usedHeight)].
+ self isAdheringToBottom
+ ifTrue: [| usedHeight |
+ usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#bottom ).
+ self bottomLeft: self owner bottomLeft + (-1 @ 1 * margin) - (0 @ usedHeight)].
+ ""
+ self isAdheringToLeft
+ ifTrue: [| usedHeight usedWidth |
+ usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ).
+ usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#left ).
+ self topLeft: self owner topLeft - margin + (usedWidth @ usedHeight)].
+ self isAdheringToRight
+ ifTrue: [| usedHeight usedWidth |
+ usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ).
+ usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#right ).
+ self topRight: self owner topRight + (1 @ -1 * margin) + (usedWidth negated @ usedHeight)]!
Item was added:
+ ----- Method: DockingBarMorph>>usedHeightByPredominantDockingBarsOfChastes: (in category 'private - accessing') -----
+ usedHeightByPredominantDockingBarsOfChastes: predominantChastes
+ "Private - convenience"
+ | predominants |
+ predominants := self predominantDockingBarsOfChastes: predominantChastes.
+ ^ predominants isEmpty
+ ifTrue: [0]
+ ifFalse: [(predominants
+ collect: [:each | each height]) sum]!
Item was added:
+ ----- Method: DockingBarMorph>>usedWidthByPredominantDockingBarsOfChastes: (in category 'private - accessing') -----
+ usedWidthByPredominantDockingBarsOfChastes: predominantChastes
+ "Private - convenience"
+ | predominants |
+ predominants := self predominantDockingBarsOfChastes: predominantChastes.
+ ^ predominants isEmpty
+ ifTrue: [0]
+ ifFalse: [(predominants
+ collect: [:each | each width]) sum]!
Item was added:
+ ----- Method: DockingBarMorph>>wantsToBeTopmost (in category 'accessing') -----
+ wantsToBeTopmost
+ "Answer if the receiver want to be one of the topmost objects in
+ its owner"
+ ^ true!
Item was added:
+ ----- Method: DockingBarMorph>>wantsYellowButtonMenu (in category 'menu') -----
+ wantsYellowButtonMenu
+ "Answer true if the receiver wants a yellow button menu"
+ ^ Preferences noviceMode not!
Item was added:
+ DockingBarMenuMorph subclass: #DockingBarUpdatingMenuMorph
+ instanceVariableNames: 'arguments updater updateSelector menuUpdater'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus-DockingBar'!
Item was added:
+ ----- Method: DockingBarUpdatingMenuMorph>>delete (in category 'as yet unclassified') -----
+ delete
+
+ owner ifNotNil: [
+ " When deleted remove my menu items, so I can avoid holding unwanted references to other objects. They will be updated anyway when I become visible again. "
+ " The owner notNil condition is necessary because MenuItemMorph >> select: sends delete before I become visible, but after the menu items are updated. "
+ self removeAllMorphs ].
+ super delete!
Item was added:
+ ----- Method: DockingBarUpdatingMenuMorph>>initialize (in category 'as yet unclassified') -----
+ initialize
+
+ super initialize.
+ menuUpdater := MenuUpdater new!
Item was added:
+ ----- Method: DockingBarUpdatingMenuMorph>>updateMenu (in category 'as yet unclassified') -----
+ updateMenu
+
+ menuUpdater update: self!
Item was added:
+ ----- Method: DockingBarUpdatingMenuMorph>>updater:updateSelector: (in category 'as yet unclassified') -----
+ updater: anObject updateSelector: aSelector
+
+ menuUpdater updater: anObject updateSelector: aSelector!
Item was added:
+ ----- Method: DockingBarUpdatingMenuMorph>>updater:updateSelector:arguments: (in category 'as yet unclassified') -----
+ updater: anObject updateSelector: aSelector arguments: anArray
+
+ menuUpdater updater: anObject updateSelector: aSelector arguments: anArray!
Item was added:
+ MorphicEvent subclass: #DropEvent
+ instanceVariableNames: 'position contents wasHandled'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: DropEvent>>contents (in category 'accessing') -----
+ contents
+ ^contents!
Item was added:
+ ----- Method: DropEvent>>copyHandlerState: (in category 'initialize') -----
+ copyHandlerState: anEvent
+ "Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
+ wasHandled := anEvent wasHandled.!
Item was added:
+ ----- Method: DropEvent>>cursorPoint (in category 'accessing') -----
+ cursorPoint
+ "For compatibility with mouse events"
+ ^position!
Item was added:
+ ----- Method: DropEvent>>isDropEvent (in category 'testing') -----
+ isDropEvent
+ ^true!
Item was added:
+ ----- Method: DropEvent>>position (in category 'accessing') -----
+ position
+ ^position!
Item was added:
+ ----- Method: DropEvent>>printOn: (in category 'printing') -----
+ printOn: aStream
+
+ aStream nextPut: $[.
+ aStream nextPutAll: self position printString; space.
+ aStream nextPutAll: self type.
+ aStream nextPut: $].!
Item was added:
+ ----- Method: DropEvent>>resetHandlerFields (in category 'initialize') -----
+ resetHandlerFields
+ "Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"
+ wasHandled := false.!
Item was added:
+ ----- Method: DropEvent>>sentTo: (in category 'dispatching') -----
+ sentTo: anObject
+ "Dispatch the receiver into anObject"
+ self type == #dropEvent ifTrue:[^anObject handleDropMorph: self].!
Item was added:
+ ----- Method: DropEvent>>setPosition:contents:hand: (in category 'private') -----
+ setPosition: pos contents: aMorph hand: aHand
+ position := pos.
+ contents := aMorph.
+ source := aHand.
+ wasHandled := false.!
Item was added:
+ ----- Method: DropEvent>>transformBy: (in category 'transforming') -----
+ transformBy: aMorphicTransform
+ "Transform the receiver into a local coordinate system."
+ position := aMorphicTransform globalPointToLocal: position.!
Item was added:
+ ----- Method: DropEvent>>transformedBy: (in category 'transforming') -----
+ transformedBy: aMorphicTransform
+ "Return the receiver transformed by the given transform into a local coordinate system."
+ ^self shallowCopy transformBy: aMorphicTransform!
Item was added:
+ ----- Method: DropEvent>>type (in category 'accessing') -----
+ type
+ ^#dropEvent!
Item was added:
+ ----- Method: DropEvent>>wasHandled (in category 'accessing') -----
+ wasHandled
+ ^wasHandled!
Item was added:
+ ----- Method: DropEvent>>wasHandled: (in category 'accessing') -----
+ wasHandled: aBool
+ wasHandled := aBool.!
Item was added:
+ DropEvent subclass: #DropFilesEvent
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: DropFilesEvent>>sentTo: (in category 'dispatching') -----
+ sentTo: anObject
+ "Dispatch the receiver into anObject"
+ self type == #dropFilesEvent ifTrue:[^anObject handleDropFiles: self].!
Item was added:
+ ----- Method: DropFilesEvent>>type (in category 'accessing') -----
+ type
+ ^#dropFilesEvent!
Item was added:
+ MenuMorph subclass: #DumberMenuMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
+
+ !DumberMenuMorph commentStamp: '<historical>' prior: 0!
+ Contributed by Bob Arning as part of the ObjectExplorer package.
+ !
Item was added:
+ ----- Method: DumberMenuMorph>>setInvokingView: (in category 'menu') -----
+ setInvokingView: invokingView
+ "I'd rather not, if that's OK"!
Item was added:
+ Object subclass: #EditCommand
+ instanceVariableNames: 'textMorph phase replacedText replacedTextInterval newText newTextInterval lastSelectionInterval'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !EditCommand commentStamp: '<historical>' prior: 0!
+ This class handles all paragraph surgery in VI. In general, subclasses of EditCommand should be able to rely on the super class' undo/redo machinery -- only the repeat command needs to be overridden in most cases. This assumes, of course, that the newText, replacedText, newTextInterval, and replacedTextInterval have been set correctly.
+
+ When setting the interval, use normal mode style selections, not insert mode selections (see class comment of VIMorphEditor).
+
+ Possible useful expressions for doIt or printIt.
+
+ Structure:
+ instVar1 type -- comment about the purpose of instVar1
+ instVar2 type -- comment about the purpose of instVar2
+
+ Any further useful comments about the general approach of this implementation.!
Item was added:
+ ----- Method: EditCommand class>>textMorph:replacedText:replacedTextInterval:newText:newTextInterval: (in category 'instance creation') -----
+ textMorph: tm
+ replacedText: replacedText
+ replacedTextInterval: replacedTextInterval
+ newText: newText
+ newTextInterval: newTextInterval
+
+
+ ^(self new)
+ textMorph: tm
+ replacedText: replacedText
+ replacedTextInterval: replacedTextInterval
+ newText: newText
+ newTextInterval: newTextInterval;
+ yourself
+
+ !
Item was added:
+ ----- Method: EditCommand>>doCommand (in category 'command execution') -----
+ doCommand
+
+ ^self redoCommand
+
+ !
Item was added:
+ ----- Method: EditCommand>>doSelectionInterval (in category 'selection') -----
+ doSelectionInterval
+ ^self redoSelectionInterval!
Item was added:
+ ----- Method: EditCommand>>iEditCommand (in category 'accessors') -----
+ iEditCommand
+ ^true!
Item was added:
+ ----- Method: EditCommand>>lastSelectionInterval (in category 'accessors') -----
+ lastSelectionInterval
+ ^lastSelectionInterval!
Item was added:
+ ----- Method: EditCommand>>newText (in category 'accessors') -----
+ newText
+ ^newText!
Item was added:
+ ----- Method: EditCommand>>newText: (in category 'accessors') -----
+ newText: aText
+ ^newText := aText!
Item was added:
+ ----- Method: EditCommand>>newTextInterval (in category 'accessors') -----
+ newTextInterval
+ ^newTextInterval!
Item was added:
+ ----- Method: EditCommand>>newTextInterval: (in category 'accessors') -----
+ newTextInterval: anInterval
+ ^newText := anInterval!
Item was added:
+ ----- Method: EditCommand>>pEditor (in category 'accessors') -----
+ pEditor
+ ^textMorph editor
+ !
Item was added:
+ ----- Method: EditCommand>>phase (in category 'accessors') -----
+ phase
+ ^phase
+ !
Item was added:
+ ----- Method: EditCommand>>phase: (in category 'accessors') -----
+ phase: aSymbol
+ ^phase := aSymbol
+ !
Item was added:
+ ----- Method: EditCommand>>printOn: (in category 'accessors') -----
+ printOn: aStream
+
+ | |
+ aStream
+ nextPutAll: self class name;
+ nextPut: $[;
+ nextPutAll: ('new: ', newTextInterval asString,' -> "', newText, '", rText: ', replacedTextInterval asString,' -> "', replacedText, '"');
+ nextPut: $].!
Item was added:
+ ----- Method: EditCommand>>redoCommand (in category 'command execution') -----
+ redoCommand
+
+ | |
+
+ "Debug dShow: ('rInterval: ', replacedTextInterval asString, '. rText: ', replacedText string, ' nInterval: ', newTextInterval asString, ' nText: ', newText string)."
+ self textMorphEditor
+ noUndoReplace: replacedTextInterval
+ with: newText.
+
+ "Debug dShow: ('lastSelInt: ', lastSelectionInterval asString)."
+ !
Item was added:
+ ----- Method: EditCommand>>redoSelectionInterval (in category 'selection') -----
+ redoSelectionInterval
+ "Return an interval to be displayed as a subtle selection after undo, or nil"
+
+ ^newTextInterval
+ !
Item was added:
+ ----- Method: EditCommand>>replacedText (in category 'accessors') -----
+ replacedText
+ ^replacedText!
Item was added:
+ ----- Method: EditCommand>>replacedText: (in category 'accessors') -----
+ replacedText: aText
+ ^replacedText := aText!
Item was added:
+ ----- Method: EditCommand>>replacedTextInterval (in category 'accessors') -----
+ replacedTextInterval
+ ^replacedTextInterval!
Item was added:
+ ----- Method: EditCommand>>replacedTextInterval: (in category 'accessors') -----
+ replacedTextInterval: anInterval
+ ^replacedTextInterval := anInterval!
Item was added:
+ ----- Method: EditCommand>>textMorph:replacedText:replacedTextInterval:newText:newTextInterval: (in category 'initialization') -----
+ textMorph: tm
+ replacedText: rText
+ replacedTextInterval: rInterval
+ newText: nText
+ newTextInterval: nInterval
+
+
+ textMorph := tm.
+ replacedText := rText.
+ replacedTextInterval := rInterval.
+ newText := nText.
+ newTextInterval := nInterval.
+
+ !
Item was added:
+ ----- Method: EditCommand>>textMorphEditor (in category 'accessors') -----
+ textMorphEditor
+ ^textMorph editor
+ !
Item was added:
+ ----- Method: EditCommand>>textMorphString (in category 'accessors') -----
+ textMorphString
+ ^textMorph text string
+ !
Item was added:
+ ----- Method: EditCommand>>textMorphStringSize (in category 'accessors') -----
+ textMorphStringSize
+ ^textMorph text string size
+ !
Item was added:
+ ----- Method: EditCommand>>undoCommand (in category 'command execution') -----
+ undoCommand
+
+ "Debug dShow: ('new Interval: ', newTextInterval asString, '. rText: ', replacedText string)."
+
+ self textMorphEditor
+ noUndoReplace: newTextInterval
+ with: replacedText.
+
+
+ !
Item was added:
+ ----- Method: EditCommand>>undoSelection (in category 'selection') -----
+ undoSelection
+ "Return an interval to be displayed as a selection after undo, or nil"
+
+ ^replacedTextInterval first to: (replacedTextInterval first + replacedText size - 1)
+ !
Item was added:
+ ----- Method: EditCommand>>undoSelectionInterval (in category 'selection') -----
+ undoSelectionInterval
+ "Return an interval to be displayed as a selection after undo, or nil"
+
+ | i |
+ i := (replacedTextInterval first min: self textMorphStringSize).
+ ^i to: i - 1
+ !
Item was added:
+ Object subclass: #Editor
+ instanceVariableNames: 'morph selectionShowing'
+ classVariableNames: 'BlinkingCursor DestructiveBackWord DumbbellCursor KeystrokeActions SelectionsMayShrink'
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !Editor commentStamp: '<historical>' prior: 0!
+ New text editors.
+ TextEditor provides most of the functionality that used to be in TextMorphEditor.
+ SmalltalkEditor is has Smalltalk code specific features.
+ SimpleEditor provides basic functionality for single line text editing. It does not handle fonts and styles, aligning and Smalltalk utilities. It handles one single line.
+ CellStyleEditor allows entering alphabetic characters using only number keys, like many cell phones do.!
Item was added:
+ ----- Method: Editor class>>blinkingCursor (in category 'preferences') -----
+ blinkingCursor
+ <preference: 'Blinking Text Cursor'
+ category: 'Morphic'
+ description: 'When true, the text cursor will blink.'
+ type: #Boolean>
+ ^ BlinkingCursor ifNil: [ true ]!
Item was added:
+ ----- Method: Editor class>>blinkingCursor: (in category 'preferences') -----
+ blinkingCursor: aBoolean
+ BlinkingCursor := aBoolean!
Item was added:
+ ----- Method: Editor class>>destructiveBackWord (in category 'preferences') -----
+ destructiveBackWord
+ <preference: 'Destructive Back-Word'
+ category: 'Morphic'
+ description: 'Indicates whether the back-word command deletes, or merely selects, the prior word.'
+ type: #Boolean>
+ ^ DestructiveBackWord ifNil: [ true ]!
Item was added:
+ ----- Method: Editor class>>destructiveBackWord: (in category 'preferences') -----
+ destructiveBackWord: aBoolean
+ DestructiveBackWord := aBoolean!
Item was added:
+ ----- Method: Editor class>>dumbbellCursor (in category 'preferences') -----
+ dumbbellCursor
+ <preference: 'Dumbbell-shaped Text Cursor'
+ category: 'Morphic'
+ description: 'When true, the text cursor assumes the shape of a dumbbell, otherwise a vertical bar..'
+ type: #Boolean>
+ ^ DumbbellCursor ifNil: [ false ]!
Item was added:
+ ----- Method: Editor class>>dumbbellCursor: (in category 'preferences') -----
+ dumbbellCursor: aBoolean
+ DumbbellCursor := aBoolean!
Item was added:
+ ----- Method: Editor class>>initialize (in category 'class initialization') -----
+ initialize
+ "
+ Editor initialize
+ "
+ self initializeKeystrokeActions.
+ self allSubclassesDo: [ :c | c initialize ]!
Item was added:
+ ----- Method: Editor class>>initializeKeystrokeActions (in category 'class initialization') -----
+ initializeKeystrokeActions
+ "Initialize the table for regular (i.e. non-command) keystroke dispatch"
+ "
+ self initializeKeystrokeActions
+ "
+ | actions |
+ actions := Array new: 256 withAll: #normalCharacter:.
+ 0 to: 31 do: [ :i | actions at: i+1 put: #noop: ].
+ actions at: 1 + 1 put: #cursorHome:. "home key"
+ actions at: 3 + 1 put: #enter:. "enter / return key"
+ actions at: 4 + 1 put: #cursorEnd:. "end key"
+ actions at: 5 + 1 put: #noop:. "insert key"
+ actions at: 8 + 1 put: #backspace:. "macDelete winBackspace key"
+ actions at: 9 + 1 put: #normalCharacter:. "tab"
+ actions at: 11 + 1 put: #cursorPageUp:. "page up key"
+ actions at: 12 + 1 put: #cursorPageDown:. "page down key"
+ actions at: 13 + 1 put: #enter:. "enter / return key"
+ actions at: 27 + 1 put: #offerMenuFromEsc:. "escape key"
+ actions at: 28 + 1 put: #cursorLeft:. "left arrow key"
+ actions at: 29 + 1 put: #cursorRight:. "right arrow key"
+ actions at: 30 + 1 put: #cursorUp:. "up arrow key"
+ actions at: 31 + 1 put: #cursorDown:. "down arrow key"
+ actions at: 127 + 1 put: #forwardDelete:. "winDelete key"
+ KeystrokeActions := actions!
Item was added:
+ ----- Method: Editor class>>selectionsMayShrink (in category 'preferences') -----
+ selectionsMayShrink
+ <preference: 'Selections may shrink'
+ category: 'Morphic'
+ description: 'When true, allows selection to shrink when using shift+cursor keys'
+ type: #Boolean>
+ ^SelectionsMayShrink ifNil:[true]!
Item was added:
+ ----- Method: Editor class>>selectionsMayShrink: (in category 'preferences') -----
+ selectionsMayShrink: aBoolean
+ SelectionsMayShrink := aBoolean!
Item was added:
+ ----- Method: Editor class>>specialShiftCmdKeys (in category 'keyboard shortcut tables') -----
+ specialShiftCmdKeys
+
+ "Private - return array of key codes that represent single keys acting
+ as if shift-command were also being pressed"
+
+ ^#(
+ 1 "home"
+ 3 "enter"
+ 4 "end"
+ 8 "backspace"
+ 11 "page up"
+ 12 "page down"
+ 27 "escape"
+ 28 "left arrow"
+ 29 "right arrow"
+ 30 "up arrow"
+ 31 "down arrow"
+ 127 "delete"
+ )!
Item was added:
+ ----- Method: Editor>>backWord: (in category 'typing/selecting keys') -----
+ backWord: aKeyboardEvent
+ ^ self class destructiveBackWord
+ ifTrue: [ self destructiveBackWord: aKeyboardEvent ]
+ ifFalse: [ self nonDestructiveBackWord: aKeyboardEvent ]!
Item was added:
+ ----- Method: Editor>>backspace: (in category 'typing/selecting keys') -----
+ backspace: aKeyboardEvent
+ "Backspace over the last character."
+
+ | startIndex |
+ aKeyboardEvent shiftPressed ifTrue: [^ self backWord: aKeyboardEvent].
+ startIndex := self markIndex +
+ (self hasCaret ifTrue: [0] ifFalse: [1]).
+ startIndex := 1 max: startIndex - 1.
+ self backTo: startIndex.
+ ^false!
Item was added:
+ ----- Method: Editor>>beginningOfLine: (in category 'private') -----
+ beginningOfLine: position
+ "Redefined in subclasses using Paragraph support"
+ ^ self beginningOfParagraph: position!
Item was added:
+ ----- Method: Editor>>beginningOfNextParagraph: (in category 'private') -----
+ beginningOfNextParagraph: position
+ | s |
+ s := self string.
+ ^ (s
+ indexOf: Character cr
+ startingAt: position
+ ifAbsent: [ s size ]) + 1!
Item was added:
+ ----- Method: Editor>>beginningOfParagraph: (in category 'private') -----
+ beginningOfParagraph: position
+ ^ (self string
+ lastIndexOf: Character cr
+ startingAt: position
+ ifAbsent: [ 0 ]) + 1.!
Item was added:
+ ----- Method: Editor>>beginningOfText (in category 'private') -----
+ beginningOfText
+ ^1!
Item was added:
+ ----- Method: Editor>>clearSelection (in category 'typing/selecting keys') -----
+ clearSelection
+
+ self selectFrom: 1 to: 0!
Item was added:
+ ----- Method: Editor>>clipboardText (in category 'menu messages') -----
+ clipboardText
+
+ ^ Clipboard clipboardText!
Item was added:
+ ----- Method: Editor>>clipboardTextPut: (in category 'menu messages') -----
+ clipboardTextPut: text
+
+ ^ Clipboard clipboardText: text!
Item was added:
+ ----- Method: Editor>>copySelection: (in category 'editing keys') -----
+ copySelection: aKeyboardEvent
+ "Copy the current text selection."
+
+ self copySelection.
+ ^true!
Item was added:
+ ----- Method: Editor>>cr: (in category 'typing/selecting keys') -----
+ cr: aKeyboardEvent
+ "Append a carriage return character to the stream of characters."
+
+ self addString: Character cr asString.
+ ^false!
Item was added:
+ ----- Method: Editor>>crWithIndent: (in category 'typing/selecting keys') -----
+ crWithIndent: aKeyboardEvent
+
+ "Only for SmalltalkEditor. Regular editors don't indent"
+ ^ self cr: aKeyboardEvent!
Item was added:
+ ----- Method: Editor>>crlf: (in category 'typing/selecting keys') -----
+ crlf: aKeyboardEvent
+ "Append a line feed character to the stream of characters."
+
+ self addString: String crlf.
+ ^false!
Item was added:
+ ----- Method: Editor>>cursorDown: (in category 'nonediting/nontyping keys') -----
+ cursorDown: aKeyboardEvent
+ "Private - Move cursor from position in current line to same position in
+ next line. If next line too short, put at end. If shift key down,
+ select."
+ self insertAndCloseTypeIn.
+ self
+ moveCursor: [:position | self
+ sameColumn: position
+ newLine: [:line | line + 1]
+ forward: true]
+ forward: true
+ event: aKeyboardEvent
+ specialBlock: [:dummy | dummy].
+ ^true!
Item was added:
+ ----- Method: Editor>>cursorLeft: (in category 'nonediting/nontyping keys') -----
+ cursorLeft: aKeyboardEvent
+ "Private - Move cursor left one character if nothing selected, otherwise
+ move cursor to beginning of selection. If the shift key is down, start
+ selecting or extending current selection. Don't allow cursor past
+ beginning of text"
+
+ self insertAndCloseTypeIn.
+ self
+ moveCursor:[:position | position - 1 max: 1]
+ forward: false
+ event: aKeyboardEvent
+ specialBlock:[:position | self previousWord: position].
+ ^ true!
Item was added:
+ ----- Method: Editor>>cursorPageDown: (in category 'nonediting/nontyping keys') -----
+ cursorPageDown: aKeyboardEvent
+
+ self insertAndCloseTypeIn.
+ self
+ moveCursor: [:position |
+ self
+ sameColumn: position
+ newLine: [:lineNo | lineNo + self pageHeight]
+ forward: true]
+ forward: true
+ event: aKeyboardEvent
+ specialBlock:[:dummy | dummy].
+ ^true!
Item was added:
+ ----- Method: Editor>>cursorPageUp: (in category 'nonediting/nontyping keys') -----
+ cursorPageUp: aKeyboardEvent
+
+ self insertAndCloseTypeIn.
+ self
+ moveCursor: [:position |
+ self
+ sameColumn: position
+ newLine: [:lineNo | lineNo - self pageHeight]
+ forward: false]
+ forward: false
+ event: aKeyboardEvent
+ specialBlock:[:dummy | dummy].
+ ^true!
Item was added:
+ ----- Method: Editor>>cursorRight: (in category 'nonediting/nontyping keys') -----
+ cursorRight: aKeyboardEvent
+ "Private - Move cursor right one character if nothing selected,
+ otherwise move cursor to end of selection. If the shift key is down,
+ start selecting characters or extending already selected characters.
+ Don't allow cursor past end of text"
+
+ self insertAndCloseTypeIn.
+ self
+ moveCursor: [:position | position + 1]
+ forward: true
+ event: aKeyboardEvent
+ specialBlock:[:position | self nextWord: position].
+ ^ true!
Item was added:
+ ----- Method: Editor>>cursorTopHome: (in category 'typing/selecting keys') -----
+ cursorTopHome: aKeyboardEvent
+ "Put cursor at beginning of text -- invoked from cmd-H shortcut, useful for keyboards that have no home key."
+
+ self selectAt: 1.
+ ^ true!
Item was added:
+ ----- Method: Editor>>cursorUp: (in category 'nonediting/nontyping keys') -----
+ cursorUp: aKeyboardEvent
+ "Private - Move cursor from position in current line to same position in
+ prior line. If prior line too short, put at end"
+
+ self insertAndCloseTypeIn.
+ self
+ moveCursor: [:position | self
+ sameColumn: position
+ newLine:[:line | line - 1]
+ forward: false]
+ forward: false
+ event: aKeyboardEvent
+ specialBlock:[:dummy | dummy].
+ ^true!
Item was added:
+ ----- Method: Editor>>cut: (in category 'editing keys') -----
+ cut: aKeyboardEvent
+ "Cut out the current text selection."
+
+ self cut.
+ ^true!
Item was added:
+ ----- Method: Editor>>deselect (in category 'current selection') -----
+ deselect
+ "If the text selection is visible on the screen, reverse its highlight."
+
+ selectionShowing ifTrue: [self reverseSelection]!
Item was added:
+ ----- Method: Editor>>destructiveBackWord: (in category 'typing/selecting keys') -----
+ destructiveBackWord: aKeyboardEvent
+ "If the selection is not a caret, delete it and leave it in the backspace buffer.
+ Else if there is typeahead, delete it.
+ Else, delete the word before the caret."
+
+ | startIndex |
+ self hasCaret
+ ifTrue: "a caret, delete at least one character"
+ [startIndex := 1 max: self markIndex - 1.
+ [startIndex > 1 and:
+ [(self string at: startIndex - 1) tokenish]]
+ whileTrue:
+ [startIndex := startIndex - 1]]
+ ifFalse: "a non-caret, just delete it"
+ [startIndex := self markIndex].
+ self backTo: startIndex.
+ ^false!
Item was added:
+ ----- Method: Editor>>endOfLine: (in category 'private') -----
+ endOfLine: position
+ "Redefined in subclasses using Paragraph support"
+ ^self endOfParagraph: position!
Item was added:
+ ----- Method: Editor>>endOfParagraph: (in category 'private') -----
+ endOfParagraph: position
+ | s |
+ s := self string.
+ ^ s
+ indexOf: Character cr
+ startingAt: position
+ ifAbsent: [ s size + 1 ].!
Item was added:
+ ----- Method: Editor>>endOfText (in category 'private') -----
+ endOfText
+ ^self string size + 1!
Item was added:
+ ----- Method: Editor>>enter: (in category 'typing/selecting keys') -----
+ enter: aKeyboardEvent
+ "Enter / return key was pressed"
+ "Process the various Enter / Return keystrokes"
+
+ morph acceptOnCR ifTrue: [
+ self closeTypeIn.
+ ^ true].
+
+ aKeyboardEvent controlKeyPressed ifTrue: [
+ ^ self cr: aKeyboardEvent ].
+ aKeyboardEvent shiftPressed ifTrue: [
+ ^ self lf: aKeyboardEvent ].
+ aKeyboardEvent commandAltKeyPressed ifTrue: [
+ ^ self crlf: aKeyboardEvent ].
+ ^ self crWithIndent: aKeyboardEvent!
Item was added:
+ ----- Method: Editor>>hasSelection (in category 'accessing-selection') -----
+ hasSelection
+ ^self hasCaret not!
Item was added:
+ ----- Method: Editor>>lf: (in category 'typing/selecting keys') -----
+ lf: aKeyboardEvent
+ "Append a line feed character to the stream of characters."
+
+ self addString: Character lf asString.
+ ^false!
Item was added:
+ ----- Method: Editor>>lineSelectAndEmptyCheck: (in category 'menu messages') -----
+ lineSelectAndEmptyCheck: returnBlock
+ "If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this."
+
+ self selectLine. "if current selection is an insertion point, then first select the entire line in which occurs before proceeding"
+ self hasSelection ifFalse: [morph flash. ^ returnBlock value]!
Item was added:
+ ----- Method: Editor>>lines (in category 'private') -----
+ lines
+ "Compute lines based on logical line breaks, not optical (which may change due to line wrapping of the editor).
+ Subclasses using kinds of Paragraphs can instead use the service provided by it."
+ | lines string lineIndex |
+ string := self string.
+ "Empty strings have no lines at all. Think of something."
+ string isEmpty ifTrue:[^{#(1 0 0)}].
+ lines := OrderedCollection new: (string size // 15).
+ lineIndex := 0.
+ string lineIndicesDo: [:start :endWithoutDelimiters :end |
+ lines addLast: {start. (lineIndex := lineIndex + 1). end}].
+ "Special workaround for last line empty."
+ (string last == Character cr or: [string last == Character lf])
+ ifTrue: [lines addLast: {string size + 1. lineIndex + 1. string size}].
+ ^lines!
Item was added:
+ ----- Method: Editor>>morph (in category 'accessing') -----
+ morph
+ ^ morph!
Item was added:
+ ----- Method: Editor>>morph: (in category 'accessing') -----
+ morph: aMorph
+ "Install a link back to the morph being edited (esp for text links)"
+ morph := aMorph !
Item was added:
+ ----- Method: Editor>>moveCursor:forward:event:specialBlock: (in category 'private') -----
+ moveCursor: directionBlock forward: forward event: aKeyboardEvent specialBlock: specialBlock
+ "Private - Move cursor.
+ directionBlock is a one argument Block that computes the new Position from a given one.
+ specialBlock is a one argumentBlock that computes the new position from a given one under the alternate semantics.
+ Note that directionBlock always is evaluated first."
+ | indices newPosition shouldSelect |
+ shouldSelect := aKeyboardEvent shiftPressed.
+ indices := self setIndices: shouldSelect forward: forward.
+ newPosition := directionBlock value: (indices at: #moving).
+ (aKeyboardEvent commandKeyPressed or: [aKeyboardEvent controlKeyPressed])
+ ifTrue: [newPosition := specialBlock value: newPosition].
+ shouldSelect
+ ifTrue: [self selectMark: (indices at: #fixed) point: newPosition - 1]
+ ifFalse: [self selectAt: newPosition]!
Item was added:
+ ----- Method: Editor>>moveCursor:forward:select: (in category 'private') -----
+ moveCursor: directionBlock forward: forward select: shouldSelect
+ "Private - Move cursor.
+ directionBlock is a one argument Block that computes the new Position from a given one.
+ specialBlock is a one argumentBlock that computes the new position from a given one under the alternate semantics.
+ Note that directionBlock always is evaluated first."
+ | indices newPosition |
+ indices := self setIndices: shouldSelect forward: forward.
+ newPosition := directionBlock value: (indices at: #moving).
+ shouldSelect
+ ifTrue: [self selectMark: (indices at: #fixed) point: newPosition - 1]
+ ifFalse: [self selectAt: newPosition]!
Item was added:
+ ----- Method: Editor>>nextWord: (in category 'private') -----
+ nextWord: position
+ | string index |
+ string := self string.
+ index := position.
+ [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]]
+ whileTrue: [index := index + 1].
+ [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]]
+ whileTrue: [index := index + 1].
+ ^ index!
Item was added:
+ ----- Method: Editor>>nonDestructiveBackWord: (in category 'typing/selecting keys') -----
+ nonDestructiveBackWord: aKeyboardEvent
+ "Select the prior word."
+ | indices newPosition |
+ self closeTypeIn.
+ indices := self
+ setIndices: true
+ forward: false.
+ newPosition := 1 max: (indices at: #moving) - 1.
+ newPosition := self previousWord: newPosition.
+ self selectMark: (indices at: #fixed) point: newPosition - 1.
+ ^ true!
Item was added:
+ ----- Method: Editor>>noop: (in category 'editing keys') -----
+ noop: aKeyboardEvent
+ "Unimplemented keyboard command; just ignore it."
+
+ ^ true!
Item was added:
+ ----- Method: Editor>>normalCharacter: (in category 'typing/selecting keys') -----
+ normalCharacter: aKeyboardEvent
+ "A nonspecial character is to be added to the stream of characters."
+
+ self addString: aKeyboardEvent keyCharacter asString.
+ ^false!
Item was added:
+ ----- Method: Editor>>paste (in category 'menu messages') -----
+ paste
+ "Paste the text from the shared buffer over the current selection and
+ redisplay if necessary. Undoer & Redoer: undoAndReselect."
+
+ self replace: self selectionInterval with: self clipboardText and:
+ [self selectAt: self pointIndex]!
Item was added:
+ ----- Method: Editor>>paste: (in category 'editing keys') -----
+ paste: aKeyboardEvent
+ "Replace the current text selection by the text in the shared buffer."
+
+ self insertAndCloseTypeIn.
+ self paste.
+ ^true!
Item was added:
+ ----- Method: Editor>>previousWord: (in category 'private') -----
+ previousWord: position
+ | string index |
+ string := self string.
+ index := position.
+ [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]]
+ whileTrue: [index := index - 1].
+ [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]]
+ whileTrue: [index := index - 1].
+ ^ index + 1!
Item was added:
+ ----- Method: Editor>>selectAll (in category 'typing/selecting keys') -----
+ selectAll
+
+ self selectFrom: 1 to: self string size!
Item was added:
+ ----- Method: Editor>>selectAll: (in category 'typing/selecting keys') -----
+ selectAll: aKeyboardEvent
+ "select everything, invoked by cmd-a. 1/17/96 sw"
+
+ self insertAndCloseTypeIn.
+ self selectFrom: 1 to: self string size.
+ ^ true!
Item was added:
+ ----- Method: Editor>>selectAt: (in category 'new selection') -----
+ selectAt: characterIndex
+ "Deselect, then place the caret before the character at characterIndex.
+ Be sure it is in view."
+
+ self selectFrom: characterIndex to: characterIndex - 1!
Item was added:
+ ----- Method: Editor>>selectInterval: (in category 'new selection') -----
+ selectInterval: anInterval
+ "Deselect, then select the specified characters inclusive.
+ Be sure the selection is in view."
+
+ self selectFrom: anInterval first to: anInterval last!
Item was added:
+ ----- Method: Editor>>selectInvisiblyFrom:to: (in category 'new selection') -----
+ selectInvisiblyFrom: start to: stop
+ "Select the designated characters, inclusive. Make no visual changes."
+
+ self markIndex: start pointIndex: stop + 1!
Item was added:
+ ----- Method: Editor>>selectInvisiblyMark:point: (in category 'new selection') -----
+ selectInvisiblyMark: mark point: point
+ "Select the designated characters, inclusive. Make no visual changes."
+
+ self markIndex: mark pointIndex: point + 1!
Item was added:
+ ----- Method: Editor>>selectMark:point: (in category 'new selection') -----
+ selectMark: mark point: point
+ "Deselect, then select the specified characters inclusive.
+ Be sure the selection is in view."
+
+ (mark = self markIndex and: [point + 1 = self pointIndex]) ifFalse: [
+ self selectInvisiblyMark: mark point: point ]!
Item was added:
+ ----- Method: Editor>>selectWord (in category 'new selection') -----
+ selectWord
+ "Select delimited text or word--the result of double-clicking."
+
+ ^self
+ selectWordLeftDelimiters: '([{<|''"
+ '
+ rightDelimiters: ')]}>|''"
+ '!
Item was added:
+ ----- Method: Editor>>selectWord: (in category 'nonediting/nontyping keys') -----
+ selectWord: aKeyboardEvent
+
+ self insertAndCloseTypeIn.
+ self selectWord.
+ ^ true!
Item was added:
+ ----- Method: Editor>>selectWordLeftDelimiters:rightDelimiters: (in category 'new selection') -----
+ selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters
+ "Select delimited text or word--the result of double-clicking."
+
+ | openDelimiter closeDelimiter direction match level
+ string here hereChar start stop |
+ string := self string.
+ string size < 2 ifTrue: [^self].
+ here := self pointIndex.
+ "Select the whole text when clicking before first or after last character"
+ (here > string size or: [here < 2]) ifTrue: [^self selectFrom: 1 to: string size].
+ openDelimiter := string at: here - 1.
+ match := leftDelimiters indexOf: openDelimiter.
+ match > 0
+ ifTrue: [
+ "delimiter is on left -- match to the right"
+ start := here.
+ direction := 1.
+ here := here - 1.
+ closeDelimiter := rightDelimiters at: match]
+ ifFalse: [
+ openDelimiter := string at: here.
+ match := rightDelimiters indexOf: openDelimiter.
+ match > 0
+ ifTrue: [
+ "delimiter is on right -- match to the left"
+ stop := here - 1.
+ direction := -1.
+ closeDelimiter := leftDelimiters at: match]
+ ifFalse: [
+ "no delimiters -- select a token"
+ direction := -1]].
+ level := 1.
+ [level > 0 and: [direction > 0
+ ifTrue: [here < string size]
+ ifFalse: [here > 1]]]
+ whileTrue: [
+ hereChar := string at: (here := here + direction).
+ match = 0
+ ifTrue: ["token scan goes left, then right"
+ hereChar tokenish
+ ifTrue: [here = 1
+ ifTrue: [
+ start := 1.
+ "go right if hit string start"
+ direction := 1]]
+ ifFalse: [
+ direction < 0
+ ifTrue: [
+ start := here + 1.
+ "go right if hit non-token"
+ direction := 1]
+ ifFalse: [level := 0]]]
+ ifFalse: ["bracket match just counts nesting level"
+ hereChar = closeDelimiter
+ ifTrue: [level := level - 1"leaving nest"]
+ ifFalse: [hereChar = openDelimiter
+ ifTrue: [level := level + 1"entering deeper nest"]]]].
+
+ level > 0 ifTrue: ["in case ran off string end" here := here + direction].
+ ^direction > 0
+ ifTrue: [self selectFrom: start to: here - 1]
+ ifFalse: [self selectFrom: here + 1 to: stop]!
Item was added:
+ ----- Method: Editor>>selectionInterval (in category 'accessing-selection') -----
+ selectionInterval
+ "Answer the interval that is currently selected."
+
+ ^self startIndex to: self stopIndex - 1 !
Item was added:
+ ----- Method: Editor>>setIndices:forward: (in category 'private') -----
+ setIndices: shiftPressed forward: forward
+ "Little helper method that sets the moving and fixed indices according to some flags."
+ | indices |
+ indices := Dictionary new.
+ (shiftPressed and:[self class selectionsMayShrink])
+ ifTrue: [
+ indices at: #moving put: self pointIndex.
+ indices at: #fixed put: self markIndex
+ ] ifFalse: [
+ forward
+ ifTrue:[
+ indices at: #moving put: self stopIndex.
+ indices at: #fixed put: self startIndex.
+ ] ifFalse: [
+ indices at: #moving put: self startIndex.
+ indices at: #fixed put: self stopIndex.
+ ]
+ ].
+ ^indices!
Item was added:
+ ----- Method: Editor>>userHasEdited (in category 'accessing') -----
+ userHasEdited
+ "Note that my text is free of user edits."
+
+ morph hasUnacceptedEdits: true!
Item was added:
+ ----- Method: Editor>>wordSelectAndEmptyCheck: (in category 'menu messages') -----
+ wordSelectAndEmptyCheck: returnBlock
+ "Ensure selecting the entire current word; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this."
+
+ self selectWord. "Select exactly a whole word"
+ self hasSelection ifFalse: [morph flash. ^ returnBlock value]!
Item was added:
+ Object subclass: #EllipseMidpointTracer
+ instanceVariableNames: 'rect x y a b aSquared bSquared d1 d2 inFirstRegion'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: EllipseMidpointTracer>>on: (in category 'initialize') -----
+ on: aRectangle
+ rect := aRectangle.
+ a := rect width // 2.
+ b := rect height // 2.
+ x := 0.
+ y := b.
+ aSquared := a * a.
+ bSquared := b * b.
+ d1 := bSquared - (aSquared * b) + (0.25 * aSquared).
+ d2 := nil.
+ inFirstRegion := true.!
Item was added:
+ ----- Method: EllipseMidpointTracer>>stepInY (in category 'computing') -----
+ stepInY
+ "Step to the next y value"
+ inFirstRegion ifTrue:[
+ "In the upper region we must step until we reach the next y value"
+ [(aSquared * (y-0.5)) > (bSquared * (x+1))] whileTrue:[
+ d1 < 0.0
+ ifTrue:[d1 := d1 + (bSquared * (2*x+3)).
+ x := x + 1]
+ ifFalse:[d1 := d1 + (bSquared * (2*x+3)) + (aSquared * (-2*y+2)).
+ y := y - 1.
+ ^x := x + 1]].
+ "Stepping into second region"
+ d2 := (bSquared * (x + 0.5) squared) + (aSquared * (y-1) squared) - (aSquared * bSquared).
+ inFirstRegion := false.
+ ].
+ "In the lower region each step is a y-step"
+ d2 < 0.0
+ ifTrue:[d2 := d2 + (bSquared * (2*x+2)) + (aSquared * (-2*y+3)).
+ x := x + 1]
+ ifFalse:[d2 := d2 + (aSquared * (-2*y+3))].
+ y := y - 1.
+ ^x!
Item was added:
+ BorderedMorph subclass: #EllipseMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !EllipseMorph commentStamp: 'kfr 10/27/2003 10:32' prior: 0!
+ A round BorderedMorph. Supports borderWidth and borderColor.
+ Only simple borderStyle is implemented.
+
+ EllipseMorph new borderWidth:10; borderColor: Color green; openInWorld.
+ EllipseMorph new borderStyle:(SimpleBorder width: 5 color: Color blue); openInWorld.!
Item was added:
+ ----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Ellipse'
+ categories: #('Graphics' 'Basic')
+ documentation: 'An elliptical or circular shape'!
Item was added:
+ ----- Method: EllipseMorph>>areasRemainingToFill: (in category 'drawing') -----
+ areasRemainingToFill: aRectangle
+ "Could be improved by quick check of inner rectangle"
+
+ ^ Array with: aRectangle!
Item was added:
+ ----- Method: EllipseMorph>>bottomLeftCorner (in category 'geometry') -----
+ bottomLeftCorner
+ ^self intersectionWithLineSegmentFromCenterTo: bounds bottomLeft
+ !
Item was added:
+ ----- Method: EllipseMorph>>bottomRightCorner (in category 'geometry') -----
+ bottomRightCorner
+ ^self intersectionWithLineSegmentFromCenterTo: bounds bottomRight
+ !
Item was added:
+ ----- Method: EllipseMorph>>canDrawBorder: (in category 'testing') -----
+ canDrawBorder: aBorderStyle
+ ^aBorderStyle style == #simple!
Item was added:
+ ----- Method: EllipseMorph>>canHaveFillStyles (in category 'visual properties') -----
+ canHaveFillStyles
+ "Return true if the receiver can have general fill styles; not just colors.
+ This method is for gradually converting old morphs."
+ ^true!
Item was added:
+ ----- Method: EllipseMorph>>closestPointTo: (in category 'geometry') -----
+ closestPointTo: aPoint
+ ^self intersectionWithLineSegmentFromCenterTo: aPoint!
Item was added:
+ ----- Method: EllipseMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+
+ | radius other delta xOverY |
+ (bounds containsPoint: aPoint) ifFalse: [^ false]. "quick elimination"
+ (bounds width = 1 or: [bounds height = 1])
+ ifTrue: [^ true]. "Degenerate case -- code below fails by a bit"
+
+ radius := bounds height asFloat / 2.
+ other := bounds width asFloat / 2.
+ delta := aPoint - bounds topLeft - (other at radius).
+ xOverY := bounds width asFloat / bounds height asFloat.
+ ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared!
Item was added:
+ ----- Method: EllipseMorph>>cornerStyle: (in category 'rounding') -----
+ cornerStyle: aSymbol
+ "Set the receiver's corner style. But, in this case, do *not*"
+
+ self removeProperty: #cornerStyle.
+ self changed!
Item was added:
+ ----- Method: EllipseMorph>>couldHaveRoundedCorners (in category 'accessing') -----
+ couldHaveRoundedCorners
+ ^ false!
Item was added:
+ ----- Method: EllipseMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 1!
Item was added:
+ ----- Method: EllipseMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color yellow!
Item was added:
+ ----- Method: EllipseMorph>>doesBevels (in category 'accessing') -----
+ doesBevels
+ ^ false!
Item was added:
+ ----- Method: EllipseMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ aCanvas isShadowDrawing
+ ifTrue: [^ aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: 0 borderColor: nil].
+ aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: borderWidth borderColor: borderColor.
+ !
Item was added:
+ ----- Method: EllipseMorph>>intersectionWithLineSegmentFromCenterTo: (in category 'geometry') -----
+ intersectionWithLineSegmentFromCenterTo: aPoint
+ | dx aSquared bSquared m mSquared xSquared x y dy |
+ (self containsPoint: aPoint)
+ ifTrue: [ ^aPoint ].
+ dx := aPoint x - self center x.
+ dy := aPoint y - self center y.
+ dx = 0
+ ifTrue: [ ^self bounds pointNearestTo: aPoint ].
+ m := dy / dx.
+ mSquared := m squared.
+ aSquared := (self bounds width / 2) squared.
+ bSquared := (self bounds height / 2) squared.
+ xSquared := 1 / ((1 / aSquared) + (mSquared / bSquared)).
+ x := xSquared sqrt.
+ dx < 0 ifTrue: [ x := x negated ].
+ y := m * x.
+ ^ self center + (x @ y) asIntegerPoint.
+ !
Item was added:
+ ----- Method: EllipseMorph>>topLeftCorner (in category 'geometry') -----
+ topLeftCorner
+ ^self intersectionWithLineSegmentFromCenterTo: bounds topLeft
+ !
Item was added:
+ ----- Method: EllipseMorph>>topRightCorner (in category 'geometry') -----
+ topRightCorner
+ ^self intersectionWithLineSegmentFromCenterTo: bounds topRight
+ !
Item was added:
+ Object subclass: #EventHandler
+ instanceVariableNames: 'mouseDownRecipient mouseDownSelector mouseMoveRecipient mouseMoveSelector mouseStillDownRecipient mouseStillDownSelector mouseUpRecipient mouseUpSelector mouseEnterRecipient mouseEnterSelector mouseLeaveRecipient mouseLeaveSelector mouseEnterDraggingRecipient mouseEnterDraggingSelector mouseLeaveDraggingRecipient mouseLeaveDraggingSelector keyStrokeRecipient keyStrokeSelector valueParameter startDragRecipient startDragSelector doubleClickSelector doubleClickRecipient doubleClickTimeoutSelector doubleClickTimeoutRecipient clickSelector clickRecipient'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
+
+ !EventHandler commentStamp: '<historical>' prior: 0!
+ Events in Morphic originate in a Hand, pass to a target morph, and are then dispatched by an EventHandler. EventHandlers support redirection of mouse and keyboard activity by specifying and independent recipient object and message selector for each of the possible events. In addition each eventHandler can supply an optional value parameter for distinguishing between, eg, events from a number of otherwise identical source morphs.
+
+ The basic protocol of an event handler is to receive a message of the form
+ mouseDown: event in: targetMorph
+ and redirect this as one of
+ mouseDownRecipient perform: mouseDownSelector0
+ mouseDownRecipient perform: mouseDownSelector1 with: event
+ mouseDownRecipient perform: mouseDownSelector2 with: event with: targetMorph
+ mouseDownRecipient perform: mouseDownSelector3 with: event with: targetMorph with: valueParameter
+ depending on the arity of the mouseDownSelector.
+ !
Item was added:
+ ----- Method: EventHandler>>allRecipients (in category 'access') -----
+ allRecipients
+ "Answer a list, without duplication, of all the objects serving as recipients to any of the events I handle. Intended for debugging/documentation use only"
+ | aList |
+ aList := OrderedCollection with: mouseDownRecipient with: mouseStillDownRecipient with: mouseUpRecipient with: mouseEnterRecipient with: mouseLeaveRecipient.
+ aList addAll: (OrderedCollection with: mouseEnterDraggingRecipient with: mouseLeaveDraggingRecipient with: doubleClickRecipient with: keyStrokeRecipient).
+ aList add: mouseMoveRecipient.
+ ^ (aList copyWithout: nil) asSet asArray!
Item was added:
+ ----- Method: EventHandler>>click:fromMorph: (in category 'events') -----
+ click: event fromMorph: sourceMorph
+ "This message is sent only when double clicks are handled."
+ ^ self
+ send: clickSelector
+ to: clickRecipient
+ withEvent: event
+ fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ "20 dec 2000 - only a few (old) conversion exists"
+
+ varDict at: 'mouseEnterLadenRecipient' ifPresent: [ :x | mouseEnterDraggingRecipient := x].
+ varDict at: 'mouseEnterLadenSelector' ifPresent: [ :x | mouseEnterDraggingSelector := x].
+ varDict at: 'mouseLeaveLadenRecipient' ifPresent: [ :x | mouseLeaveDraggingRecipient := x].
+ varDict at: 'mouseLeaveLadenSelector' ifPresent: [ :x | mouseLeaveDraggingSelector := x].
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: EventHandler>>doubleClick:fromMorph: (in category 'events') -----
+ doubleClick: event fromMorph: sourceMorph
+ ^ self
+ send: doubleClickSelector
+ to: doubleClickRecipient
+ withEvent: event
+ fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>doubleClickTimeout:fromMorph: (in category 'events') -----
+ doubleClickTimeout: event fromMorph: sourceMorph
+ ^ self
+ send: doubleClickTimeoutSelector
+ to: doubleClickTimeoutRecipient
+ withEvent: event
+ fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>firstMouseSelector (in category 'access') -----
+ firstMouseSelector
+ "Answer the selector corresponding to the first mouse-handling selector fielded. Created in support of providing balloon-help for halo handles, triggered by the selector handled"
+
+ mouseDownSelector ifNotNil: [^ mouseDownSelector].
+ mouseMoveSelector ifNotNil:[^mouseMoveSelector].
+ mouseStillDownSelector ifNotNil: [^ mouseStillDownSelector].
+ mouseUpSelector ifNotNil: [^ mouseUpSelector].
+ mouseEnterSelector ifNotNil: [^ mouseEnterSelector].
+ mouseLeaveSelector ifNotNil: [^ mouseLeaveSelector].
+ mouseEnterDraggingSelector ifNotNil: [^ mouseEnterDraggingSelector].
+ mouseLeaveDraggingSelector ifNotNil: [^ mouseLeaveDraggingSelector].
+ doubleClickSelector ifNotNil: [^ doubleClickSelector].
+ ^ nil!
Item was added:
+ ----- Method: EventHandler>>fixReversedValueMessages (in category 'fixups') -----
+ fixReversedValueMessages
+ "ar 3/18/2001: Due to the change in the ordering of the value parameter old event handlers may have messages that need to be fixed up. Do this here."
+
+ self replaceSendsIn: #( renameCharAction:sourceMorph:requestor: makeGetter:from:forPart: makeSetter:from:forPart: newMakeGetter:from:forPart: newMakeSetter:from:forPart: clickOnLine:evt:envelope: limitHandleMoveEvent:from:index: mouseUpEvent:linkMorph:formData: mouseUpEvent:linkMorph:browserAndUrl: mouseDownEvent:noteMorph:pitch: mouseMoveEvent:noteMorph:pitch: mouseUpEvent:noteMorph:pitch: dragVertex:fromHandle:vertIndex: dropVertex:fromHandle:vertIndex: newVertex:fromHandle:afterVert: prefMenu:rcvr:pref: event:arrow:upDown:
+ newMakeGetter:from:forMethodInterface:)
+ with: #( renameCharAction:event:sourceMorph: makeGetter:event:from: makeSetter:event:from: newMakeGetter:event:from: newMakeSetter:event:from: clickOn:evt:from: limitHandleMove:event:from: mouseUpFormData:event:linkMorph: mouseUpBrowserAndUrl:event:linkMorph: mouseDownPitch:event:noteMorph: mouseMovePitch:event:noteMorph: mouseUpPitch:event:noteMorph: dragVertex:event:fromHandle: dropVertex:event:fromHandle: newVertex:event:fromHandle: prefMenu:event:rcvr: upDown:event:arrow: makeUniversalTilesGetter:event:from:).
+
+ "sw 3/28/2001 extended Andreas's original lists by one item"!
Item was added:
+ ----- Method: EventHandler>>handlesClickOrDrag: (in category 'testing') -----
+ handlesClickOrDrag: evt
+ clickRecipient ifNotNil:[^true].
+ doubleClickRecipient ifNotNil:[^true].
+ startDragRecipient ifNotNil:[^true].
+ ^false!
Item was added:
+ ----- Method: EventHandler>>handlesGestureStart: (in category 'testing') -----
+ handlesGestureStart: evt
+ "Does the associated morph want to handle gestures?"
+ ^false!
Item was added:
+ ----- Method: EventHandler>>handlesKeyboard: (in category 'testing') -----
+ handlesKeyboard: evt
+ keyStrokeRecipient ifNotNil: [^ true].
+ ^ false!
Item was added:
+ ----- Method: EventHandler>>handlesMouseDown: (in category 'testing') -----
+ handlesMouseDown: evt
+ mouseDownRecipient ifNotNil: [^ true].
+ mouseStillDownRecipient ifNotNil: [^ true].
+ mouseUpRecipient ifNotNil: [^ true].
+ (self handlesClickOrDrag: evt) ifTrue:[^true].
+ ^self handlesGestureStart: evt!
Item was added:
+ ----- Method: EventHandler>>handlesMouseMove: (in category 'testing') -----
+ handlesMouseMove: evt
+ ^mouseMoveRecipient notNil and:[mouseMoveSelector notNil]!
Item was added:
+ ----- Method: EventHandler>>handlesMouseOver: (in category 'testing') -----
+ handlesMouseOver: evt
+ mouseEnterRecipient ifNotNil: [^ true].
+ mouseLeaveRecipient ifNotNil: [^ true].
+ ^ false!
Item was added:
+ ----- Method: EventHandler>>handlesMouseOverDragging: (in category 'testing') -----
+ handlesMouseOverDragging: evt
+ mouseEnterDraggingRecipient ifNotNil: [^ true].
+ mouseLeaveDraggingRecipient ifNotNil: [^ true].
+ ^ false!
Item was added:
+ ----- Method: EventHandler>>handlesMouseStillDown: (in category 'testing') -----
+ handlesMouseStillDown: evt
+ ^mouseStillDownRecipient notNil and:[mouseStillDownSelector notNil]!
Item was added:
+ ----- Method: EventHandler>>keyStroke:fromMorph: (in category 'events') -----
+ keyStroke: event fromMorph: sourceMorph
+ ^ self send: keyStrokeSelector to: keyStrokeRecipient withEvent: event fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>messageList (in category 'access') -----
+ messageList
+ "Return a list of 'Class selector' for each message I can send. tk
+ 9/13/97"
+ | list |
+ self flag: #mref.
+ "is this still needed? I replaced the one use that I could spot with
+ #methodRefList "
+ list := SortedCollection new.
+ mouseDownRecipient
+ ifNotNil: [list add: (mouseDownRecipient class whichClassIncludesSelector: mouseDownSelector) name , ' ' , mouseDownSelector].
+ mouseMoveRecipient
+ ifNotNil: [list add: (mouseMoveRecipient class whichClassIncludesSelector: mouseMoveSelector) name , ' ' , mouseMoveSelector].
+ mouseStillDownRecipient
+ ifNotNil: [list add: (mouseStillDownRecipient class whichClassIncludesSelector: mouseStillDownSelector) name , ' ' , mouseStillDownSelector].
+ mouseUpRecipient
+ ifNotNil: [list add: (mouseUpRecipient class whichClassIncludesSelector: mouseUpSelector) name , ' ' , mouseUpSelector].
+ mouseEnterRecipient
+ ifNotNil: [list add: (mouseEnterRecipient class whichClassIncludesSelector: mouseEnterSelector) name , ' ' , mouseEnterSelector].
+ mouseLeaveRecipient
+ ifNotNil: [list add: (mouseLeaveRecipient class whichClassIncludesSelector: mouseLeaveSelector) name , ' ' , mouseLeaveSelector].
+ mouseEnterDraggingRecipient
+ ifNotNil: [list add: (mouseEnterDraggingRecipient class whichClassIncludesSelector: mouseEnterDraggingSelector) name , ' ' , mouseEnterDraggingSelector].
+ mouseLeaveDraggingRecipient
+ ifNotNil: [list add: (mouseLeaveDraggingRecipient class whichClassIncludesSelector: mouseLeaveDraggingSelector) name , ' ' , mouseLeaveDraggingSelector].
+ doubleClickRecipient
+ ifNotNil: [list add: (doubleClickRecipient class whichClassIncludesSelector: doubleClickSelector) name , ' ' , doubleClickSelector].
+ keyStrokeRecipient
+ ifNotNil: [list add: (keyStrokeRecipient class whichClassIncludesSelector: keyStrokeSelector) name , ' ' , keyStrokeSelector].
+ ^ list!
Item was added:
+ ----- Method: EventHandler>>methodRefList (in category 'access') -----
+ methodRefList
+ "Return a MethodReference for each message I can send. tk 9/13/97, raa
+ 5/29/01 "
+ | list adder |
+ list := SortedCollection new.
+ adder := [:recip :sel | recip
+ ifNotNil: [list
+ add: (MethodReference new
+ class: (recip class whichClassIncludesSelector: sel)
+ selector: sel)]].
+ adder value: mouseDownRecipient value: mouseDownSelector.
+ adder value: mouseMoveRecipient value: mouseMoveSelector.
+ adder value: mouseStillDownRecipient value: mouseStillDownSelector.
+ adder value: mouseUpRecipient value: mouseUpSelector.
+ adder value: mouseEnterRecipient value: mouseEnterSelector.
+ adder value: mouseLeaveRecipient value: mouseLeaveSelector.
+ adder value: mouseEnterDraggingRecipient value: mouseEnterDraggingSelector.
+ adder value: mouseLeaveDraggingRecipient value: mouseLeaveDraggingSelector.
+ adder value: doubleClickRecipient value: doubleClickSelector.
+ adder value: keyStrokeRecipient value: keyStrokeSelector.
+ ^ list!
Item was added:
+ ----- Method: EventHandler>>mouseDown:fromMorph: (in category 'events') -----
+ mouseDown: event fromMorph: sourceMorph
+ "Take double-clicks into account."
+ ((self handlesClickOrDrag: event) and:[event redButtonPressed]) ifTrue:[
+ event hand waitForClicksOrDrag: sourceMorph event: event.
+ ].
+ ^self
+ send: mouseDownSelector
+ to: mouseDownRecipient
+ withEvent: event
+ fromMorph: sourceMorph.
+ !
Item was added:
+ ----- Method: EventHandler>>mouseDownSelector (in category 'access') -----
+ mouseDownSelector
+ ^ mouseDownSelector!
Item was added:
+ ----- Method: EventHandler>>mouseEnter:fromMorph: (in category 'events') -----
+ mouseEnter: event fromMorph: sourceMorph
+ ^ self send: mouseEnterSelector to: mouseEnterRecipient withEvent: event fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>mouseEnterDragging:fromMorph: (in category 'events') -----
+ mouseEnterDragging: event fromMorph: sourceMorph
+ ^ self send: mouseEnterDraggingSelector to: mouseEnterDraggingRecipient withEvent: event fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>mouseLeave:fromMorph: (in category 'events') -----
+ mouseLeave: event fromMorph: sourceMorph
+ ^ self send: mouseLeaveSelector to: mouseLeaveRecipient withEvent: event fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>mouseLeaveDragging:fromMorph: (in category 'events') -----
+ mouseLeaveDragging: event fromMorph: sourceMorph
+ ^ self send: mouseLeaveDraggingSelector to: mouseLeaveDraggingRecipient withEvent: event fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>mouseMove:fromMorph: (in category 'events') -----
+ mouseMove: event fromMorph: sourceMorph
+ ^ self send: mouseMoveSelector to: mouseMoveRecipient withEvent: event fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>mouseStillDown:fromMorph: (in category 'events') -----
+ mouseStillDown: event fromMorph: sourceMorph
+ ^ self send: mouseStillDownSelector to: mouseStillDownRecipient withEvent: event fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>mouseStillDownRecipient (in category 'access') -----
+ mouseStillDownRecipient
+ ^mouseStillDownRecipient!
Item was added:
+ ----- Method: EventHandler>>mouseStillDownSelector (in category 'access') -----
+ mouseStillDownSelector
+ ^mouseStillDownSelector!
Item was added:
+ ----- Method: EventHandler>>mouseUp:fromMorph: (in category 'events') -----
+ mouseUp: event fromMorph: sourceMorph
+ ^ self send: mouseUpSelector to: mouseUpRecipient withEvent: event fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>mouseUpSelector (in category 'access') -----
+ mouseUpSelector
+ ^ mouseUpSelector!
Item was added:
+ ----- Method: EventHandler>>on:send:to: (in category 'initialization') -----
+ on: eventName send: selector to: recipient
+ eventName == #mouseDown ifTrue:
+ [mouseDownRecipient := recipient. mouseDownSelector := selector. ^ self].
+ eventName == #mouseMove ifTrue:
+ [mouseMoveRecipient := recipient. mouseMoveSelector := selector. ^ self].
+ eventName == #mouseStillDown ifTrue:
+ [mouseStillDownRecipient := recipient. mouseStillDownSelector := selector. ^ self].
+ eventName == #mouseUp ifTrue:
+ [mouseUpRecipient := recipient. mouseUpSelector := selector. ^ self].
+ eventName == #mouseEnter ifTrue:
+ [mouseEnterRecipient := recipient. mouseEnterSelector := selector. ^ self].
+ eventName == #mouseLeave ifTrue:
+ [mouseLeaveRecipient := recipient. mouseLeaveSelector := selector. ^ self].
+ eventName == #mouseEnterDragging ifTrue:
+ [mouseEnterDraggingRecipient := recipient. mouseEnterDraggingSelector := selector. ^ self].
+ eventName == #mouseLeaveDragging ifTrue:
+ [mouseLeaveDraggingRecipient := recipient. mouseLeaveDraggingSelector := selector. ^ self].
+ eventName == #click ifTrue:
+ [clickRecipient := recipient. clickSelector := selector. ^ self].
+ eventName == #doubleClick ifTrue:
+ [doubleClickRecipient := recipient. doubleClickSelector := selector. ^ self].
+ eventName == #doubleClickTimeout ifTrue:
+ [doubleClickTimeoutRecipient := recipient. doubleClickTimeoutSelector := selector. ^ self].
+ eventName == #startDrag ifTrue:
+ [startDragRecipient := recipient. startDragSelector := selector. ^ self].
+ eventName == #keyStroke ifTrue:
+ [keyStrokeRecipient := recipient. keyStrokeSelector := selector. ^ self].
+ eventName == #gesture ifTrue:
+ [ ^self onGestureSend: selector to: recipient ].
+ self error: 'Event name, ' , eventName , ' is not recognizable.'
+ !
Item was added:
+ ----- Method: EventHandler>>on:send:to:withValue: (in category 'initialization') -----
+ on: eventName send: selector to: recipient withValue: value
+ selector numArgs = 3 ifFalse:
+ [self halt: 'Warning: value parameters are passed as first of 3 arguments'].
+ self on: eventName send: selector to: recipient.
+ valueParameter := value
+ !
Item was added:
+ ----- Method: EventHandler>>onGestureSend:to: (in category 'initialization') -----
+ onGestureSend: selector to: recipient!
Item was added:
+ ----- Method: EventHandler>>printOn: (in category 'printing') -----
+ printOn: aStream
+ | recipients |
+ super printOn: aStream.
+ #('mouseDownSelector' 'mouseStillDownSelector' 'mouseUpSelector' 'mouseEnterSelector' 'mouseLeaveSelector' 'mouseEnterDraggingSelector' 'mouseLeaveDraggingSelector' 'doubleClickSelector' 'keyStrokeSelector')
+ do:
+ [:aName | | aVal |
+ (aVal := self instVarNamed: aName) notNil
+ ifTrue: [aStream nextPutAll: '; ' , aName , '=' , aVal]].
+ (recipients := self allRecipients) notEmpty
+ ifTrue:
+ [aStream nextPutAll: ' recipients: '.
+ recipients printOn: aStream]!
Item was added:
+ ----- Method: EventHandler>>replaceSendsIn:with: (in category 'fixups') -----
+ replaceSendsIn: array1 with: array2
+ "Replace all the sends that occur in array1 with those in array2. Used for fixing old event handlers in files."
+ | old index |
+ 1 to: self class instSize do:[:i|
+ old := self instVarAt: i.
+ index := array1 identityIndexOf: old.
+ index > 0 ifTrue:[self instVarAt: i put: (array2 at: index)]].!
Item was added:
+ ----- Method: EventHandler>>send:to:withEvent:fromMorph: (in category 'events') -----
+ send: selector to: recipient withEvent: event fromMorph: sourceMorph
+ | arity |
+ recipient ifNil: [^ self].
+ arity := selector numArgs.
+ arity = 0 ifTrue:
+ [^ recipient perform: selector].
+ arity = 1 ifTrue:
+ [^ recipient perform: selector with: event].
+ arity = 2 ifTrue:
+ [^ recipient perform: selector with: event with: sourceMorph].
+ arity = 3 ifTrue:
+ [^ recipient perform: selector with: valueParameter with: event with: sourceMorph].
+ self error: 'Event handling selectors must be Symbols and take 0-3 arguments'!
Item was added:
+ ----- Method: EventHandler>>startDrag:fromMorph: (in category 'events') -----
+ startDrag: event fromMorph: sourceMorph
+ ^ self
+ send: startDragSelector
+ to: startDragRecipient
+ withEvent: event
+ fromMorph: sourceMorph!
Item was added:
+ ----- Method: EventHandler>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ | old |
+ "ALL inst vars were weakly copied. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ 1 to: self class instSize do:
+ [:ii | old := self instVarAt: ii.
+ self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])].
+
+ !
Item was added:
+ ----- Method: EventHandler>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "ALL fields are weakly copied!! Can't duplicate an object by duplicating a button that activates it. See DeepCopier."
+
+ super veryDeepInner: deepCopier.
+ "just keep old pointers to all fields"
+ !
Item was added:
+ ListItemWrapper subclass: #FileDirectoryWrapper
+ instanceVariableNames: 'itemName balloonText hasContents'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
Item was added:
+ ----- Method: FileDirectoryWrapper class>>with:name:model: (in category 'as yet unclassified') -----
+ with: anObject name: aString model: aModel
+
+ ^self new
+ setItem: anObject name: aString model: aModel!
Item was added:
+ ----- Method: FileDirectoryWrapper>>asString (in category 'converting') -----
+ asString
+ ^itemName translatedIfCorresponds!
Item was added:
+ ----- Method: FileDirectoryWrapper>>balloonText (in category 'accessing') -----
+ balloonText
+
+ ^balloonText!
Item was added:
+ ----- Method: FileDirectoryWrapper>>balloonText: (in category 'as yet unclassified') -----
+ balloonText: aStringOrNil
+
+ balloonText := aStringOrNil!
Item was added:
+ ----- Method: FileDirectoryWrapper>>contents (in category 'accessing') -----
+ contents
+
+ ^((model directoryNamesFor: item) sortBy: [ :a :b | a caseInsensitiveLessOrEqual: b]) collect: [ :n |
+ FileDirectoryWrapper with: (item directoryNamed: n) name: n model: self
+ ]
+ !
Item was added:
+ ----- Method: FileDirectoryWrapper>>directoryNamesFor: (in category 'as yet unclassified') -----
+ directoryNamesFor: anItem
+ ^model directoryNamesFor: anItem!
Item was added:
+ ----- Method: FileDirectoryWrapper>>hasContents (in category 'accessing') -----
+ hasContents
+ "Return whether this directory has subfolders. The value is cached to
+ avoid a performance penalty. Also for performance reasons, the code
+ below will just assume that the directory does indeed have contents in a
+ few of cases:
+ 1. If the item is not a FileDirectory (thus avoiding the cost
+ of refreshing directories that are not local)
+ 2. If it's the root directory of a given volume
+ 3. If there is an error computing the FileDirectory's contents
+ "
+ hasContents
+ ifNil: [hasContents := true. "default"
+ ["Best test I could think of for determining if this is a local directory "
+ ((item isKindOf: FileDirectory)
+ and: ["test to see that it's not the root directory"
+ "there has to be a better way of doing this test -tpr"
+ item pathParts size > 1])
+ ifTrue: [hasContents := self contents notEmpty]]
+ on: Error
+ do: [hasContents := true]].
+ ^ hasContents!
Item was added:
+ ----- Method: FileDirectoryWrapper>>icon (in category 'accessing') -----
+ icon
+ "Answer a form to be used as icon"
+ ^ item isRemoteDirectory
+ ifTrue: [MenuIcons smallRemoteOpenIcon]
+ ifFalse: [MenuIcons smallOpenIcon]!
Item was added:
+ ----- Method: FileDirectoryWrapper>>setItem:name:model: (in category 'as yet unclassified') -----
+ setItem: anObject name: aString model: aModel
+
+ item := anObject.
+ model := aModel.
+ itemName := aString.
+ hasContents := nil.
+ !
Item was added:
+ ----- Method: FileDirectoryWrapper>>settingSelector (in category 'as yet unclassified') -----
+ settingSelector
+
+ ^#setSelectedDirectoryTo:!
Item was added:
+ RectangleMorph subclass: #FillInTheBlankMorph
+ instanceVariableNames: 'response done textPane responseUponCancel'
+ classVariableNames: 'RoundedDialogCorners'
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: FillInTheBlankMorph class>>defaultAnswerExtent (in category 'default constants') -----
+ defaultAnswerExtent
+ ^ (200 at 60 * (Preferences standardMenuFont height / 12)) rounded!
Item was added:
+ ----- Method: FillInTheBlankMorph class>>request: (in category 'instance creation') -----
+ request: queryString
+ "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels."
+ "FillInTheBlankMorph request: 'What is your favorite color?'"
+
+ ^ self
+ request: queryString
+ initialAnswer: ''
+ centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint!
Item was added:
+ ----- Method: FillInTheBlankMorph class>>request:initialAnswer: (in category 'instance creation') -----
+ request: queryString initialAnswer: defaultAnswer
+ "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels."
+ "FillInTheBlankMorph
+ request: 'What is your favorite color?'
+ initialAnswer: 'red, no blue. Ahhh!!'"
+
+ ^ self
+ request: queryString
+ initialAnswer: defaultAnswer
+ centerAt: ActiveHand cursorPoint!
Item was added:
+ ----- Method: FillInTheBlankMorph class>>request:initialAnswer:centerAt: (in category 'instance creation') -----
+ request: queryString initialAnswer: defaultAnswer centerAt: aPoint
+ "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels.
+ This variant is only for calling from within a Morphic project."
+ "FillInTheBlankMorph
+ request: 'Type something, then type CR.'
+ initialAnswer: 'yo ho ho!!'
+ centerAt: Display center"
+
+ ^ self
+ request: queryString
+ initialAnswer: defaultAnswer
+ centerAt: aPoint
+ inWorld: ActiveWorld
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph class>>request:initialAnswer:centerAt:inWorld: (in category 'instance creation') -----
+ request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld
+ "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels."
+ "FillInTheBlankMorph
+ request: 'Type something, then type CR.'
+ initialAnswer: 'yo ho ho!!'
+ centerAt: Display center"
+
+ ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: ''!
Item was added:
+ ----- Method: FillInTheBlankMorph class>>request:initialAnswer:centerAt:inWorld:onCancelReturn: (in category 'instance creation') -----
+ request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel
+ "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel. If user hits cr, treat it as a normal accept."
+
+ "FillInTheBlankMorph
+ request: 'Type something, then type CR.'
+ initialAnswer: 'yo ho ho!!'
+ centerAt: Display center"
+
+ ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: true!
Item was added:
+ ----- Method: FillInTheBlankMorph class>>request:initialAnswer:centerAt:inWorld:onCancelReturn:acceptOnCR: (in category 'instance creation') -----
+ request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean
+ "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel."
+
+ ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint
+ inWorld: aWorld onCancelReturn: returnOnCancel
+ acceptOnCR: acceptBoolean answerExtent: self defaultAnswerExtent!
Item was added:
+ ----- Method: FillInTheBlankMorph class>>request:initialAnswer:centerAt:inWorld:onCancelReturn:acceptOnCR:answerExtent: (in category 'instance creation') -----
+ request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerExtent: answerExtent
+ "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel."
+ "FillInTheBlankMorph
+ request: 'Type something, then type CR.'
+ initialAnswer: 'yo ho ho!!'
+ centerAt: Display center"
+
+ | aFillInTheBlankMorph |
+ aFillInTheBlankMorph := self new
+ setQuery: queryString
+ initialAnswer: defaultAnswer
+ answerExtent: answerExtent
+ acceptOnCR: acceptBoolean.
+ aFillInTheBlankMorph responseUponCancel: returnOnCancel.
+ aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint.
+ ^ aFillInTheBlankMorph getUserResponse
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph class>>request:initialAnswer:centerAt:inWorld:onCancelReturn:acceptOnCR:answerHeight: (in category 'instance creation') -----
+ request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerHeight: answerHeight
+ "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel."
+ ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint
+ inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean
+ answerExtent: self defaultAnswerExtent x @ answerHeight!
Item was added:
+ ----- Method: FillInTheBlankMorph class>>requestPassword: (in category 'instance creation') -----
+ requestPassword: queryString
+ "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels."
+ "use password font"
+ "FillInTheBlankMorph requestPassword: 'Password?'"
+
+ ^ self
+ requestPassword: queryString
+ initialAnswer: ''
+ centerAt: Sensor cursorPoint
+ inWorld: World
+ onCancelReturn: ''
+ acceptOnCR: true
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph class>>requestPassword:initialAnswer:centerAt:inWorld:onCancelReturn:acceptOnCR: (in category 'instance creation') -----
+ requestPassword: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean
+ "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel."
+ "FillInTheBlankMorph
+ request: 'Type something, then type CR.'
+ initialAnswer: 'yo ho ho!!'
+ centerAt: Display center"
+
+ | aFillInTheBlankMorph |
+ aFillInTheBlankMorph := self new
+ setPasswordQuery: queryString
+ initialAnswer: defaultAnswer
+ answerHeight: 50
+ acceptOnCR: acceptBoolean.
+ aFillInTheBlankMorph responseUponCancel: returnOnCancel.
+ aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint.
+ ^ aFillInTheBlankMorph getUserResponse
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph class>>roundedDialogCorners (in category 'preferences') -----
+ roundedDialogCorners
+ <preference: 'Rounded Dialog Corners'
+ category: 'windows'
+ description: 'Governs whether dialog windows should have rounded corners'
+ type: #Boolean>
+ ^ RoundedDialogCorners ifNil: [ true ]!
Item was added:
+ ----- Method: FillInTheBlankMorph class>>roundedDialogCorners: (in category 'preferences') -----
+ roundedDialogCorners: aBoolean
+
+ RoundedDialogCorners := aBoolean.
+ self allInstances do: [:instance |
+ aBoolean
+ ifTrue: [instance useRoundedCorners]
+ ifFalse: [instance useSquareCorners]].!
Item was added:
+ ----- Method: FillInTheBlankMorph>>accept (in category 'menu') -----
+ accept
+ "Sent by the accept button."
+
+ textPane accept.
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>cancel (in category 'menu') -----
+ cancel
+ "Sent by the cancel button."
+
+ response := responseUponCancel.
+ done := true.
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>codePaneMenu:shifted: (in category 'menu') -----
+ codePaneMenu: aMenu shifted: shifted
+
+ ^ StringHolder codePaneMenu: aMenu shifted: shifted.
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>convertToCurrentVersion:refStream: (in category 'object fileIn') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ varDict at: 'responseUponCancel' ifAbsent: [responseUponCancel := ''].
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>createAcceptButton (in category 'initialization') -----
+ createAcceptButton
+ "create the [accept] button"
+ | result frame |
+ result := SimpleButtonMorph new target: self;
+ color: ColorTheme current okColor.
+ result
+ borderColor: (Preferences menuAppearance3d
+ ifTrue: [#raised]
+ ifFalse: [result color twiceDarker]).
+ result label: 'Accept(s)' translated;
+ actionSelector: #accept.
+ result setNameTo: 'accept'.
+ frame := LayoutFrame new.
+ frame rightFraction: 0.5;
+ rightOffset: -10;
+ bottomFraction: 1.0;
+ bottomOffset: -2.
+ result layoutFrame: frame.
+ self addMorph: result.
+ self
+ updateColor: result
+ color: result color
+ intensity: 2.
+ ^ result!
Item was added:
+ ----- Method: FillInTheBlankMorph>>createCancelButton (in category 'initialization') -----
+ createCancelButton
+ "create the [cancel] button"
+ | result frame |
+ result := SimpleButtonMorph new target: self;
+ color: ColorTheme current cancelColor.
+ result
+ borderColor: (Preferences menuAppearance3d
+ ifTrue: [#raised]
+ ifFalse: [result color twiceDarker]).
+ result label: 'Cancel(l)' translated;
+ actionSelector: #cancel.
+ result setNameTo: 'cancel'.
+ frame := LayoutFrame new.
+ frame leftFraction: 0.5;
+ leftOffset: 10;
+ bottomFraction: 1.0;
+ bottomOffset: -2.
+ result layoutFrame: frame.
+ self addMorph: result.
+ self
+ updateColor: result
+ color: result color
+ intensity: 2.
+ ^ result!
Item was added:
+ ----- Method: FillInTheBlankMorph>>createQueryTextMorph: (in category 'initialization') -----
+ createQueryTextMorph: queryString
+ "create the queryTextMorph"
+ | result frame |
+ result := TextMorph new contents: queryString.
+ result setNameTo: 'query' translated.
+ result lock.
+ frame := LayoutFrame new.
+ frame topFraction: 0.0;
+ topOffset: 2.
+ frame leftFraction: 0.5;
+ leftOffset: (result width // 2) negated.
+ result layoutFrame: frame.
+ self addMorph: result.
+ ^ result!
Item was added:
+ ----- Method: FillInTheBlankMorph>>createTextPaneExtent:acceptBoolean:topOffset:buttonAreaHeight: (in category 'initialization') -----
+ createTextPaneExtent: answerExtent acceptBoolean: acceptBoolean topOffset: topOffset buttonAreaHeight: buttonAreaHeight
+ "create the textPane"
+ | result frame |
+ result := PluggableTextMorph
+ on: self
+ text: #response
+ accept: #response:
+ readSelection: #selectionInterval
+ menu: #codePaneMenu:shifted:.
+ result
+ extent: answerExtent;
+ alwaysShowScrollBars: false;
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ borderWidth: 1;
+ hasUnacceptedEdits: true;
+ acceptOnCR: acceptBoolean;
+ setNameTo: 'textPane'.
+ frame := LayoutFrame new
+ leftFraction: 0.0;
+ rightFraction: 1.0;
+ topFraction: 0.0;
+ topOffset: topOffset;
+ bottomFraction: 1.0;
+ bottomOffset: buttonAreaHeight negated;
+ yourself.
+ result layoutFrame: frame.
+ self addMorph: result.
+ ^ result!
Item was added:
+ ----- Method: FillInTheBlankMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color white!
Item was added:
+ ----- Method: FillInTheBlankMorph>>delete (in category 'initialization') -----
+ delete
+
+ self breakDependents.
+ super delete.!
Item was added:
+ ----- Method: FillInTheBlankMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "change the receiver's extent"
+
+ super extent: aPoint .
+ self setDefaultParameters.
+ self updateColor!
Item was added:
+ ----- Method: FillInTheBlankMorph>>getUserResponse (in category 'invoking') -----
+ getUserResponse
+ "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels."
+ "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."
+
+ | w |
+ w := self world.
+ w ifNil: [^ response].
+
+ (ProvideAnswerNotification signal:
+ (self submorphOfClass: TextMorph) userString) ifNotNil:
+ [:answer |
+ self delete.
+ w doOneCycle.
+ ^ response := (answer == #default) ifTrue: [response] ifFalse: [answer]].
+
+ done := false.
+ w activeHand newKeyboardFocus: textPane.
+ [done] whileFalse: [w doOneCycle].
+ self delete.
+ w doOneCycle.
+ ^ response
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ ^true!
Item was added:
+ ----- Method: FillInTheBlankMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ self setDefaultParameters.
+ self extent: 400 @ 150.
+ responseUponCancel := ''.
+ self class roundedDialogCorners ifTrue: [self useRoundedCorners].
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>morphicLayerNumber (in category 'invoking') -----
+ morphicLayerNumber
+
+ ^10.6!
Item was added:
+ ----- Method: FillInTheBlankMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ (self containsPoint: evt position) ifFalse:[^ Beeper beep]. "sent in response to outside modal click"
+ evt hand grabMorph: self. "allow repositioning"!
Item was added:
+ ----- Method: FillInTheBlankMorph>>response (in category 'accessing') -----
+ response
+
+ ^ response
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>response: (in category 'accessing') -----
+ response: aText
+ "Sent when text pane accepts."
+
+ response := aText asString.
+ done := true.
+ ^ true
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>responseUponCancel: (in category 'initialization') -----
+ responseUponCancel: anObject
+ responseUponCancel := anObject
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>selectionInterval (in category 'accessing') -----
+ selectionInterval
+ ^ 1 to: response size
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>setDefaultParameters (in category 'initialization') -----
+ setDefaultParameters
+ "change the receiver's appareance parameters"
+
+ | colorFromMenu worldColor menuColor |
+
+ colorFromMenu := Preferences menuColorFromWorld
+ and: [Display depth > 4
+ and: [(worldColor := self currentWorld color) isColor]].
+
+ menuColor := colorFromMenu
+ ifTrue: [worldColor luminance > 0.7
+ ifTrue: [worldColor mixed: 0.85 with: Color black]
+ ifFalse: [worldColor mixed: 0.4 with: Color white]]
+ ifFalse: [Preferences menuColor].
+
+ self color: menuColor.
+ self borderWidth: Preferences menuBorderWidth.
+
+ Preferences menuAppearance3d ifTrue: [
+ self borderStyle: BorderStyle thinGray.
+ self hasDropShadow: true.
+
+ self useSoftDropShadow
+ ifFalse: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666);
+ shadowOffset: 1 @ 1]
+ ifTrue: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.01);
+ shadowOffset: (10 at 8 corner: 10 at 12) ]
+ ]
+ ifFalse: [
+ | menuBorderColor |
+ menuBorderColor := colorFromMenu
+ ifTrue: [worldColor muchDarker]
+ ifFalse: [Preferences menuBorderColor].
+ self borderColor: menuBorderColor.
+ ].
+
+
+ self layoutInset: 3.
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>setPasswordQuery:initialAnswer:answerHeight:acceptOnCR: (in category 'initialization') -----
+ setPasswordQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean
+ | pane |
+ self setQuery: queryString
+ initialAnswer: initialAnswer
+ answerHeight: answerHeight
+ acceptOnCR: acceptBoolean.
+ pane := self submorphNamed: 'textPane'.
+ pane font: (StrikeFont passwordFontSize: 12).!
Item was added:
+ ----- Method: FillInTheBlankMorph>>setQuery:initialAnswer:answerExtent:acceptOnCR: (in category 'initialization') -----
+ setQuery: queryString initialAnswer: initialAnswer answerExtent: answerExtent acceptOnCR: acceptBoolean
+ | query topOffset accept cancel buttonAreaHeight |
+ response := initialAnswer.
+ done := false.
+ self removeAllMorphs.
+ self layoutPolicy: ProportionalLayout new.
+ query := self createQueryTextMorph: queryString.
+ topOffset := query height + 4.
+ accept := self createAcceptButton.
+ cancel := self createCancelButton.
+ buttonAreaHeight := (accept height max: cancel height)
+ + 7.
+ textPane := self
+ createTextPaneExtent: answerExtent
+ acceptBoolean: acceptBoolean
+ topOffset: topOffset
+ buttonAreaHeight: buttonAreaHeight.
+ self extent: (query extent x max: answerExtent x)
+ + 4 @ (topOffset + answerExtent y + 4 + buttonAreaHeight).
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>setQuery:initialAnswer:answerHeight:acceptOnCR: (in category 'initialization') -----
+ setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean
+ self setQuery: queryString initialAnswer: initialAnswer
+ answerExtent: (self class defaultAnswerExtent x @ answerHeight)
+ acceptOnCR: acceptBoolean
+ !
Item was added:
+ ----- Method: FillInTheBlankMorph>>undoGrabCommand (in category 'grabbing/dropping') -----
+ undoGrabCommand
+ ^nil!
Item was added:
+ ----- Method: FillInTheBlankMorph>>updateColor (in category 'initialization') -----
+ updateColor
+ "update the recevier's fillStyle"
+ | textPaneBorderColor |
+ self
+ updateColor: self
+ color: self color
+ intensity: 1.
+ textPane isNil
+ ifTrue: [^ self].
+ textPaneBorderColor := self borderColor == #raised
+ ifTrue: [#inset]
+ ifFalse: [self borderColor].
+ textPane borderColor: textPaneBorderColor!
Item was added:
+ ----- Method: FillInTheBlankMorph>>updateColor:color:intensity: (in category 'initialization') -----
+ updateColor: aMorph color: aColor intensity: anInteger
+ "update the apareance of aMorph"
+ | fill |
+ MenuMorph gradientMenu
+ ifFalse: [^ self].
+
+ fill := GradientFillStyle ramp: {0.0 -> Color white. 1 -> aColor}.
+ fill radial: false;
+ origin: aMorph topLeft;
+ direction: 0 @ aMorph height.
+ aMorph fillStyle: fill!
Item was added:
+ NullEncoder subclass: #FlattenEncoder
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !FlattenEncoder commentStamp: '<historical>' prior: 0!
+ The simplest possible encoding: leave the objects as is.
+ !
Item was added:
+ ----- Method: FlattenEncoder class>>filterSelector (in category 'configuring') -----
+ filterSelector
+ ^#flattenOnStream:
+ !
Item was added:
+ ----- Method: FlattenEncoder>>cr (in category 'writing') -----
+ cr
+ ^self print:String cr.
+
+ !
Item was added:
+ ----- Method: FlattenEncoder>>elementSeparator (in category 'filter streaming') -----
+ elementSeparator
+ ^target elementSeparator.!
Item was added:
+ ----- Method: FlattenEncoder>>writeArrayedCollection: (in category 'writing') -----
+ writeArrayedCollection:anArrayedCollection
+ ^self writeCollectionContents:anArrayedCollection.
+
+ !
Item was added:
+ ----- Method: FlattenEncoder>>writeCollection: (in category 'writing') -----
+ writeCollection:aCollection
+ ^self writeCollectionContents:aCollection.
+
+ !
Item was added:
+ ----- Method: FlattenEncoder>>writeCollectionContents: (in category 'writing') -----
+ writeCollectionContents:aCollection
+ ^self writeCollectionContents:aCollection separator:self elementSeparator iterationMessage:#do:.
+
+ !
Item was added:
+ ----- Method: FlattenEncoder>>writeCollectionContents:separator: (in category 'writing') -----
+ writeCollectionContents:aCollection separator:separator
+ ^self writeCollectionContents:aCollection separator:separator iterationMessage:#do:.!
Item was added:
+ ----- Method: FlattenEncoder>>writeCollectionContents:separator:iterationMessage: (in category 'writing') -----
+ writeCollectionContents:aCollection separator:separator iterationMessage:op
+ | first |
+ first := true.
+ aCollection perform:op with: [ :each | first ifFalse:[ self writeObject:separator ]. self write:each. first:=false.].
+ !
Item was added:
+ ----- Method: FlattenEncoder>>writeDictionary: (in category 'writing') -----
+ writeDictionary:aCollection
+ ^self writeDictionaryContents:aCollection separator:nil.
+
+ !
Item was added:
+ ----- Method: FlattenEncoder>>writeDictionaryContents:separator: (in category 'writing') -----
+ writeDictionaryContents:aCollection separator:separator
+ ^self writeCollectionContents:aCollection separator:separator iterationMessage:#associationsDo:.!
Item was added:
+ ----- Method: Float>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
+ hasContentsInExplorer
+
+ ^false!
Item was added:
+ Model subclass: #FontChooserTool
+ instanceVariableNames: 'title selectedFontIndex fontList target getSelector setSelector pointSize emphasis window result offerStyleList'
+ classVariableNames: 'Default'
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !FontChooserTool commentStamp: 'ar 8/30/2009 14:28' prior: 0!
+ A ToolBuilder version of FreeTypePlus' FontChooser[Morph].!
Item was added:
+ ----- Method: FontChooserTool class>>default (in category 'accessing') -----
+ default
+ "Answer the default font chooser tool"
+ ^Default ifNil:[self]!
Item was added:
+ ----- Method: FontChooserTool class>>default: (in category 'accessing') -----
+ default: aFontChooser
+ "Answer the default font chooser tool"
+ Default := aFontChooser!
Item was added:
+ ----- Method: FontChooserTool class>>open (in category 'opening') -----
+ open
+ "
+ FontChooserTool open.
+ "
+ ^self new open!
Item was added:
+ ----- Method: FontChooserTool class>>openWithWindowTitle:for:setSelector:getSelector: (in category 'opening') -----
+ openWithWindowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector
+ "
+ FontChooserTool
+ openWithWindowTitle: 'Choose the Menu Font'
+ for: Preferences
+ setSelector: #setMenuFontTo:
+ getSelector: #standardMenuFont.
+ "
+ ^(self withTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector) open!
Item was added:
+ ----- Method: FontChooserTool class>>windowTitle:for:setSelector:getSelector: (in category 'opening') -----
+ windowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector
+ | instance |
+
+ instance := self new.
+ instance
+ title: titleString;
+ target: anObject;
+ setSelector: setSelector;
+ getSelector: getSelector.
+ ^instance open!
Item was added:
+ ----- Method: FontChooserTool class>>withTitle:for:setSelector:getSelector: (in category 'opening') -----
+ withTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector
+ "
+ (FontChooserTool
+ withTitle: 'Choose the Menu Font'
+ for: Preferences
+ setSelector: #setMenuFontTo:
+ getSelector: #standardMenuFont) open.
+ "
+ | instance |
+ instance := self new.
+ instance
+ title: titleString;
+ target: anObject;
+ setSelector: setSelector;
+ getSelector: getSelector.
+ ^instance!
Item was added:
+ ----- Method: FontChooserTool>>accept (in category 'actions') -----
+ accept
+ self apply.
+ result := self selectedFont.
+ ToolBuilder default close: window.!
Item was added:
+ ----- Method: FontChooserTool>>apply (in category 'actions') -----
+ apply
+ | font |
+ target ifNotNil:[
+ setSelector ifNotNil:[
+ font := self selectedFont.
+ font ifNotNil:[
+ target perform: setSelector with: font]]].!
Item was added:
+ ----- Method: FontChooserTool>>buildButtonBarWith: (in category 'toolbuilder') -----
+ buildButtonBarWith: builder
+ "Build the button bar"
+ | panelSpec buttonSpec |
+ panelSpec := builder pluggablePanelSpec new.
+ panelSpec children: OrderedCollection new.
+
+ buttonSpec := builder pluggableButtonSpec new.
+ buttonSpec
+ model: self;
+ label: ' Apply ' translated;
+ action: #apply;
+ frame: (0.0 at 0 corner: 0.33 at 1).
+ panelSpec children addLast: buttonSpec.
+
+
+ buttonSpec := builder pluggableButtonSpec new.
+ buttonSpec
+ model: self;
+ label: ' OK ' translated;
+ action: #accept;
+ frame: (0.33 at 0 corner: 0.67 at 1).
+ panelSpec children addLast: buttonSpec.
+
+ buttonSpec := builder pluggableButtonSpec new.
+ buttonSpec
+ model: self;
+ label: ' Cancel ' translated;
+ action: #cancel;
+ frame: (0.67 at 0 corner: 1 at 1).
+ panelSpec children addLast: buttonSpec.
+
+ ^panelSpec!
Item was added:
+ ----- Method: FontChooserTool>>buildFontListWith: (in category 'toolbuilder') -----
+ buildFontListWith: builder
+ "Build the font choosers list of font names"
+ | listSpec |
+ listSpec := builder pluggableListSpec new.
+ listSpec
+ model: self;
+ list: #fontList;
+ getIndex: #selectedFontIndex;
+ setIndex: #selectedFontIndex:.
+ ^listSpec
+ !
Item was added:
+ ----- Method: FontChooserTool>>buildPointSizeListWith: (in category 'toolbuilder') -----
+ buildPointSizeListWith: builder
+ "Build the font choosers list of point sizes"
+ | listSpec |
+ listSpec := builder pluggableListSpec new.
+ listSpec
+ model: self;
+ list: #pointSizeList;
+ getIndex: #selectedPointSizeIndex;
+ setIndex: #selectedPointSizeIndex:.
+ ^listSpec
+ !
Item was added:
+ ----- Method: FontChooserTool>>buildPreviewPaneWith: (in category 'toolbuilder') -----
+ buildPreviewPaneWith: builder
+ "Build the preview panel"
+ | textSpec |
+ textSpec := builder pluggableTextSpec new.
+ textSpec
+ name: #preview;
+ model: self;
+ getText: #contents.
+ ^textSpec!
Item was added:
+ ----- Method: FontChooserTool>>buildStyleListWith: (in category 'toolbuilder') -----
+ buildStyleListWith: builder
+ "Build the font choosers list of font styles"
+ | listSpec |
+ listSpec := builder pluggableListSpec new.
+ listSpec
+ model: self;
+ list: #fontStyleList;
+ getIndex: #selectedFontStyleIndex;
+ setIndex: #selectedFontStyleIndex:.
+ ^listSpec
+ !
Item was added:
+ ----- Method: FontChooserTool>>buildWindowWith: (in category 'toolbuilder') -----
+ buildWindowWith: builder
+ | windowSpec |
+ windowSpec := builder pluggableWindowSpec new.
+ windowSpec model: self.
+ windowSpec label: #windowTitle.
+ windowSpec children: OrderedCollection new.
+ ^windowSpec!
Item was added:
+ ----- Method: FontChooserTool>>buildWindowWith:specs: (in category 'toolbuilder') -----
+ buildWindowWith: builder specs: specs
+ | windowSpec |
+ windowSpec := self buildWindowWith: builder.
+ specs do:[:assoc| | action widgetSpec rect |
+ rect := assoc key.
+ action := assoc value.
+ widgetSpec := action value.
+ widgetSpec ifNotNil:[
+ widgetSpec frame: rect.
+ windowSpec children add: widgetSpec]].
+ ^windowSpec!
Item was added:
+ ----- Method: FontChooserTool>>buildWith: (in category 'toolbuilder') -----
+ buildWith: builder
+ "Create the ui for the browser"
+ "ToolBuilder open: self"
+ | windowSpec |
+ self offerStyleList ifTrue:[
+ windowSpec := self buildWindowWith: builder specs: {
+ (0 at 0 corner: 0.4 at 0.4) -> [self buildFontListWith: builder].
+ (0.4 at 0 corner: 0.8 at 0.4) -> [self buildStyleListWith: builder].
+ (0.8 at 0 corner: 1.0 at 0.4) -> [self buildPointSizeListWith: builder].
+ (0.0 at 0.4 corner: 1.0 at 0.88) -> [self buildPreviewPaneWith: builder].
+ (0.0 at 0.88 corner: 1 at 1) -> [self buildButtonBarWith: builder].
+ }.
+ ] ifFalse:[
+ windowSpec := self buildWindowWith: builder specs: {
+ (0 at 0 corner: 0.7 at 0.4) -> [self buildFontListWith: builder].
+ " (0.4 at 0 corner: 0.8 at 0.4) -> [self buildStyleListWith: builder]."
+ (0.7 at 0 corner: 1.0 at 0.4) -> [self buildPointSizeListWith: builder].
+ (0.0 at 0.4 corner: 1.0 at 0.8) -> [self buildPreviewPaneWith: builder].
+ (0.0 at 0.8 corner: 1 at 1) -> [self buildButtonBarWith: builder].
+ }.
+ ].
+ windowSpec extent: self initialExtent.
+ window := builder build: windowSpec.
+ "Yes, that's a hack. But it looks ugly with line breaks."
+ (builder widgetAt: #preview) textMorph wrapFlag: false.
+ ^window!
Item was added:
+ ----- Method: FontChooserTool>>cancel (in category 'actions') -----
+ cancel
+ result := nil.
+ ToolBuilder default close: window.!
Item was added:
+ ----- Method: FontChooserTool>>contents (in category 'toolbuilder') -----
+ contents
+ | sample i c f |
+ sample := WriteStream on: ''.
+ f := self selectedFont ifNil:[^Text new].
+ f isSymbolFont ifFalse:[
+ sample
+ nextPutAll: 'the quick brown fox jumps over the lazy dog' ;cr;
+ nextPutAll: 'THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG.' ;cr;cr;
+ nextPutAll: '0123456789'; cr; cr;
+ nextPutAll:
+ 'Lorem ipsum dolor sit amet, consectetur adipisicing elit,
+ sed do eiusmod tempor incididunt ut labore et dolore
+ magna aliqua. Ut enim ad minim veniam, quis nostrud
+ exercitation ullamco laboris nisi ut aliquip ex ea commodo
+ consequat. Duis aute irure dolor in reprehenderit in voluptate
+ velit esse cillum dolore eu fugiat nulla pariatur. Excepteur
+ sint occaecat cupidatat non proident, sunt in culpa qui
+ officia deserunt mollit anim id est laborum.'
+ ] ifTrue:[
+ i := 0.
+ 33 to: 255 do:[:ci |
+ sample nextPut: (c:=Character value: ci).
+ i := i + 1.
+ (('@Z`z' includes:c) or:[i = 30])
+ ifTrue:[i :=0. sample cr]].
+ ].
+ sample := sample contents asText.
+ sample addAttribute: (TextFontReference toFont: f).
+ ^sample!
Item was added:
+ ----- Method: FontChooserTool>>fontList (in category 'font list') -----
+ fontList
+ "List of available font family names"
+ ^fontList ifNil:[fontList := TextStyle knownTextStyles]!
Item was added:
+ ----- Method: FontChooserTool>>fontStyleList (in category 'style list') -----
+ fontStyleList
+ "names of simulated styles are enclosed in parenthesis"
+ ^#('Regular' 'Bold' 'Italic' 'Bold Italic')!
Item was added:
+ ----- Method: FontChooserTool>>getSelector (in category 'accessing') -----
+ getSelector
+ "Answer the value of getSelector"
+
+ ^ getSelector!
Item was added:
+ ----- Method: FontChooserTool>>getSelector: (in category 'accessing') -----
+ getSelector: aSelectorSymbolOrFont
+ "Set the value of getSelector"
+
+ getSelector := aSelectorSymbolOrFont!
Item was added:
+ ----- Method: FontChooserTool>>initialExtent (in category 'initialize') -----
+ initialExtent
+ ^self offerStyleList ifTrue:[400 at 300] ifFalse:[300 at 200].!
Item was added:
+ ----- Method: FontChooserTool>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ title := 'Choose A Font'.
+ getSelector := TextStyle defaultFont.
+ emphasis := 0.
+ offerStyleList := true.!
Item was added:
+ ----- Method: FontChooserTool>>offerStyleList (in category 'initialize') -----
+ offerStyleList
+ "Whether to offer a choice of styles with the font."
+ ^offerStyleList!
Item was added:
+ ----- Method: FontChooserTool>>offerStyleList: (in category 'initialize') -----
+ offerStyleList: aBool
+ "Whether to offer a choice of styles with the font."
+ offerStyleList := aBool!
Item was added:
+ ----- Method: FontChooserTool>>open (in category 'toolbuilder') -----
+ open
+ ^ToolBuilder open: self!
Item was added:
+ ----- Method: FontChooserTool>>pointSize (in category 'point size') -----
+ pointSize
+ ^pointSize ifNil: [pointSize := 10.0]!
Item was added:
+ ----- Method: FontChooserTool>>pointSize: (in category 'point size') -----
+ pointSize: aNumber
+ pointSize := aNumber.
+ self changed: #pointSize.
+ self changed: #contents.!
Item was added:
+ ----- Method: FontChooserTool>>pointSizeList (in category 'point size') -----
+ pointSizeList
+ ^self selectedTextStyle pointSizes collect: [:each | each asString padded: #left to: 3 with: $ ]!
Item was added:
+ ----- Method: FontChooserTool>>result (in category 'accessing') -----
+ result
+ ^result!
Item was added:
+ ----- Method: FontChooserTool>>selectedFont (in category 'font list') -----
+ selectedFont
+ | font |
+ font := self selectedTextStyle fontOfPointSize: pointSize.
+ ^font emphasized: emphasis!
Item was added:
+ ----- Method: FontChooserTool>>selectedFontFamily (in category 'font list') -----
+ selectedFontFamily
+ ^self fontList at: self selectedFontIndex ifAbsent:[nil].
+
+ !
Item was added:
+ ----- Method: FontChooserTool>>selectedFontIndex (in category 'font list') -----
+ selectedFontIndex
+ | font textStyleName family |
+ selectedFontIndex ifNotNil: [^selectedFontIndex].
+ selectedFontIndex := 0.
+ font := (getSelector isSymbol and:[target notNil])
+ ifTrue:[target perform: getSelector]
+ ifFalse:[getSelector].
+ font ifNotNil:[
+ emphasis := font emphasis.
+ pointSize := font pointSize.
+ textStyleName := font textStyleName.
+ family := self fontList detect:[:f | f = textStyleName] ifNone:[].
+ ].
+ selectedFontIndex := self fontList indexOf: family ifAbsent:[0].
+ self selectedFontIndex: selectedFontIndex.
+ ^selectedFontIndex!
Item was added:
+ ----- Method: FontChooserTool>>selectedFontIndex: (in category 'font list') -----
+ selectedFontIndex: anIndex
+ anIndex = 0 ifTrue: [^self].
+ selectedFontIndex := anIndex.
+ self changed: #selectedFontIndex.
+ self changed: #selectedFontStyleIndex.
+ self changed: #pointSizeList.
+ self changed: #pointSizeIndex.
+ self changed: #contents.!
Item was added:
+ ----- Method: FontChooserTool>>selectedFontStyleIndex (in category 'style list') -----
+ selectedFontStyleIndex
+ "This is a hack"
+ ^emphasis+1!
Item was added:
+ ----- Method: FontChooserTool>>selectedFontStyleIndex: (in category 'style list') -----
+ selectedFontStyleIndex: anIndex
+ anIndex = 0 ifTrue: [^self].
+ emphasis := anIndex - 1.
+ self changed: #selectedFontStyleIndex.
+ self changed: #contents.!
Item was added:
+ ----- Method: FontChooserTool>>selectedPointSize (in category 'point size') -----
+ selectedPointSize
+ ^self selectedFont pointSize!
Item was added:
+ ----- Method: FontChooserTool>>selectedPointSizeIndex (in category 'point size') -----
+ selectedPointSizeIndex
+ ^self pointSizeList indexOf: (pointSize reduce asString padded: #left to: 3 with: $ )!
Item was added:
+ ----- Method: FontChooserTool>>selectedPointSizeIndex: (in category 'point size') -----
+ selectedPointSizeIndex: anIndex
+
+ anIndex = 0 ifTrue: [^self].
+ pointSize := (self pointSizeList at: anIndex) withBlanksTrimmed asNumber.
+ self changed: #pointSizeList.
+ self changed: #contents.!
Item was added:
+ ----- Method: FontChooserTool>>selectedTextStyle (in category 'font list') -----
+ selectedTextStyle
+
+ ^TextStyle named: (self selectedFontFamily ifNil:[^TextStyle default]).!
Item was added:
+ ----- Method: FontChooserTool>>setSelector: (in category 'accessing') -----
+ setSelector: anObject
+ "Set the value of setSelector"
+
+ setSelector := anObject!
Item was added:
+ ----- Method: FontChooserTool>>target (in category 'accessing') -----
+ target
+ "Answer the value of target"
+
+ ^ target!
Item was added:
+ ----- Method: FontChooserTool>>target: (in category 'accessing') -----
+ target: anObject
+ "Set the value of target"
+
+ target := anObject!
Item was added:
+ ----- Method: FontChooserTool>>title: (in category 'accessing') -----
+ title: anObject
+ "Set the value of title"
+
+ title := anObject!
Item was added:
+ ----- Method: FontChooserTool>>window (in category 'accessing') -----
+ window
+ ^window!
Item was added:
+ ----- Method: FontChooserTool>>windowTitle (in category 'initialize') -----
+ windowTitle
+ ^ title translated!
Item was added:
+ Object subclass: #FontImporterFontDescription
+ instanceVariableNames: 'fontname filename children parent'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: FontImporterFontDescription>><= (in category 'comparing') -----
+ <= other
+
+ ^ self fontname asString <= other fontname asString!
Item was added:
+ ----- Method: FontImporterFontDescription>>addChild: (in category 'accessing') -----
+ addChild: aChild
+
+ ^ self children add: aChild!
Item was added:
+ ----- Method: FontImporterFontDescription>>allFilenames (in category 'accessing') -----
+ allFilenames
+
+ ^ self filename
+ ifNil: [
+ (self children
+ select: [:child | child filename notNil]
+ thenCollect: [:child | child filename])
+ asSet asArray]
+ ifNotNil: [:f | {f}] !
Item was added:
+ ----- Method: FontImporterFontDescription>>children (in category 'accessing') -----
+ children
+
+ ^ children ifNil: [children := OrderedCollection new].!
Item was added:
+ ----- Method: FontImporterFontDescription>>children: (in category 'accessing') -----
+ children: anObject
+
+ children := anObject!
Item was added:
+ ----- Method: FontImporterFontDescription>>filename (in category 'accessing') -----
+ filename
+
+ ^ filename!
Item was added:
+ ----- Method: FontImporterFontDescription>>filename: (in category 'accessing') -----
+ filename: anObject
+
+ filename := anObject!
Item was added:
+ ----- Method: FontImporterFontDescription>>fontname (in category 'accessing') -----
+ fontname
+
+ ^ fontname!
Item was added:
+ ----- Method: FontImporterFontDescription>>fontname: (in category 'accessing') -----
+ fontname: anObject
+
+ fontname := anObject!
Item was added:
+ ----- Method: FontImporterFontDescription>>hasChildren (in category 'testing') -----
+ hasChildren
+
+ ^ self children notNil and: [self children notEmpty]!
Item was added:
+ ----- Method: FontImporterFontDescription>>normalize (in category 'actions') -----
+ normalize
+
+ self children size = 1 ifTrue: [ | pseudoChild |
+ pseudoChild := self children removeFirst.
+ (self filename notNil and: [pseudoChild filename ~= self filename])
+ ifTrue: [self error: 'Inconsistent state'].
+ self filename: pseudoChild filename]!
Item was added:
+ ----- Method: FontImporterFontDescription>>parent (in category 'accessing') -----
+ parent
+
+ ^ parent!
Item was added:
+ ----- Method: FontImporterFontDescription>>parent: (in category 'accessing') -----
+ parent: anObject
+
+ parent := anObject!
Item was added:
+ ----- Method: FontImporterFontDescription>>printOn: (in category 'printing') -----
+ printOn: aStream
+
+ self parent ifNotNil: [:p | aStream nextPutAll: p fontname; nextPut: $ ].
+ aStream nextPutAll: self fontname.
+ self children notEmpty ifTrue: [aStream nextPut: $ ].
+ self children
+ do: [:subfont | aStream nextPutAll: subfont fontname]
+ separatedBy: [aStream nextPut: $/].
+ aStream nextPut: $ ; nextPut: $(.
+ self allFilenames
+ do: [:filename | aStream nextPutAll: filename]
+ separatedBy: [aStream nextPut: $,; nextPut: $ ].
+ aStream nextPut: $).
+ !
Item was added:
+ StringHolder subclass: #FontImporterTool
+ instanceVariableNames: 'title allFonts emphasis window currentSelection currentParent warningSeen'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !FontImporterTool commentStamp: 'topa 3/9/2015 18:56' prior: 0!
+ A tool to import platform (native) fonts into the image!
Item was added:
+ ----- Method: FontImporterTool class>>default (in category 'accessing') -----
+ default
+ "Answer the default font imporer tool, ie me
+ (polymorphic with font chooser)
+ "
+ ^ self!
Item was added:
+ ----- Method: FontImporterTool class>>initialize (in category 'class initialization') -----
+ initialize
+
+ self registerInOpenMenu.!
Item was added:
+ ----- Method: FontImporterTool class>>open (in category 'opening') -----
+ open
+ "
+ FontChooserTool open.
+ "
+ ^self new open!
Item was added:
+ ----- Method: FontImporterTool class>>openWithWindowTitle:for:setSelector:getSelector: (in category 'opening') -----
+ openWithWindowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector
+ "
+ FontChooserTool
+ openWithWindowTitle: 'Choose the Menu Font'
+ for: Preferences
+ setSelector: #setMenuFontTo:
+ getSelector: #standardMenuFont.
+ "
+ ^(self withTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector) open!
Item was added:
+ ----- Method: FontImporterTool class>>registerInOpenMenu (in category 'class initialization') -----
+ registerInOpenMenu
+ (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [
+ TheWorldMenu unregisterOpenCommand: 'Font Importer'.
+ TheWorldMenu registerOpenCommand: {'Font Importer'. {self. #open}}].
+ !
Item was added:
+ ----- Method: FontImporterTool class>>unload (in category 'class initialization') -----
+ unload
+
+ self unregisterFromOpenMenu.!
Item was added:
+ ----- Method: FontImporterTool class>>unregisterFromOpenMenu (in category 'class initialization') -----
+ unregisterFromOpenMenu
+ (TheWorldMenu respondsTo: #registerOpenCommand:)
+ ifTrue: [TheWorldMenu unregisterOpenCommand: 'Font Importer'].
+ !
Item was added:
+ ----- Method: FontImporterTool class>>windowTitle:for:setSelector:getSelector: (in category 'opening') -----
+ windowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector
+ | instance |
+
+ instance := self new.
+ instance
+ title: titleString;
+ target: anObject;
+ setSelector: setSelector;
+ getSelector: getSelector.
+ ^instance open!
Item was added:
+ ----- Method: FontImporterTool class>>withTitle:for:setSelector:getSelector: (in category 'opening') -----
+ withTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector
+ "
+ (FontChooserTool
+ withTitle: 'Choose the Menu Font'
+ for: Preferences
+ setSelector: #setMenuFontTo:
+ getSelector: #standardMenuFont) open.
+ "
+ | instance |
+ instance := self new.
+ instance
+ title: titleString;
+ target: anObject;
+ setSelector: setSelector;
+ getSelector: getSelector.
+ ^instance!
Item was added:
+ ----- Method: FontImporterTool>>allFonts (in category 'accessing') -----
+ allFonts
+ ^ allFonts ifNil: [ | fonts |
+ fonts := Dictionary new.
+ Cursor wait showWhile: [
+ TTFileDescription fontPathsDo:[:path |
+ TTFileDescription fontFilesIn: path do:[:font| | fontDesc filename fname |
+ filename := path, FileDirectory slash, font fileName.
+ fname := self textForFamily: font familyName subfamily: nil.
+ fontDesc := fonts
+ at: font familyName
+ ifAbsentPut: (FontImporterFontDescription new fontname: fname; yourself).
+ font subfamilyName
+ ifNil: [fontDesc filename: filename]
+ ifNotNil: [ |subfontDesc sname |
+ sname := self textForFamily: font familyName subfamily: font subfamilyName.
+ subfontDesc := FontImporterFontDescription new fontname: sname; yourself.
+ subfontDesc
+ parent: fontDesc;
+ filename: filename.
+ fontDesc addChild: subfontDesc]]]].
+ allFonts := fonts values sorted.
+ allFonts do: [:fontDesc | fontDesc normalize].
+ allFonts].
+
+ !
Item was added:
+ ----- Method: FontImporterTool>>allFonts: (in category 'accessing') -----
+ allFonts: anObject
+
+ allFonts := anObject.
+ self changed: #allFonts.!
Item was added:
+ ----- Method: FontImporterTool>>buildButtonBarWith: (in category 'toolbuilder') -----
+ buildButtonBarWith: builder
+ "Build the button bar"
+ | panelSpec buttonSpec |
+ panelSpec := builder pluggablePanelSpec new.
+ panelSpec children: OrderedCollection new.
+
+ buttonSpec := builder pluggableButtonSpec new
+ model: self;
+ label: ' Import ' translated;
+ help: 'Include the font data in the image and provide a TextStyle for the font';
+ action: #import;
+ frame: (0 at 0 corner: 0.5 at 1);
+ yourself.
+ panelSpec children addLast: buttonSpec.
+
+
+ buttonSpec := builder pluggableButtonSpec new
+ model: self;
+ label: ' Close ' translated;
+ action: #close;
+ frame: (0.5 at 0 corner: 1 at 1);
+ yourself.
+ panelSpec children addLast: buttonSpec.
+
+
+ ^panelSpec!
Item was added:
+ ----- Method: FontImporterTool>>buildFontListWith: (in category 'toolbuilder') -----
+ buildFontListWith: builder
+ "Build the font choosers list of font names"
+
+ ^ builder pluggableTreeSpec new
+ model: self;
+ roots: #allFonts;
+ label: #labelOf: ;
+ getChildren: #childrenOf: ;
+ getSelected: #currentSelection;
+ setSelected: #currentSelection:;
+ setSelectedParent: #currentParent:;
+ menu: #fontListMenu:;
+ autoDeselect: false;
+ yourself
+ !
Item was added:
+ ----- Method: FontImporterTool>>buildPreviewPaneWith: (in category 'toolbuilder') -----
+ buildPreviewPaneWith: builder
+ "Build the preview panel"
+
+ ^ builder pluggablePanelSpec new
+ children: {
+ builder pluggableTextSpec new
+ model: self;
+ getText: #filename;
+ frame: (LayoutFrame
+ fractions: (0 at 0 corner: 1 at 0)
+ offsets: (0 at 0 corner: 0@ -25));
+ yourself.
+
+ (self buildCodePaneWith: builder)
+ name: #preview;
+ frame: (LayoutFrame
+ fractions: (0 at 0 corner: 1 at 0.75)
+ offsets: (0@ 30 corner: 0 at 0));
+ yourself.
+
+ builder pluggableTextSpec new
+ model: self;
+ getText: #copyright;
+ frame: (LayoutFrame
+ fractions: (0 at 0.75 corner: 1 at 1));
+ yourself
+
+ };
+ yourself!
Item was added:
+ ----- Method: FontImporterTool>>buildWith: (in category 'toolbuilder') -----
+ buildWith: builder
+ "Create the ui for the browser"
+ "ToolBuilder open: self"
+ | windowSpec |
+ windowSpec := self buildWindowWith: builder specs: {
+ (self fontListFrame) -> [self buildFontListWith: builder].
+ (self previewFrame) -> [self buildPreviewPaneWith: builder].
+ (self buttonsFrame) -> [self buildButtonBarWith: builder].
+ }.
+ windowSpec extent: self initialExtent.
+ window := builder build: windowSpec.
+ "Yes, that's a hack. But it looks ugly with line breaks."
+ (builder widgetAt: #preview) textMorph wrapFlag: false.
+ ^window!
Item was added:
+ ----- Method: FontImporterTool>>buttonHeight (in category 'toolbuilder') -----
+ buttonHeight
+ ^Preferences standardButtonFont height + 25!
Item was added:
+ ----- Method: FontImporterTool>>buttonsFrame (in category 'toolbuilder') -----
+ buttonsFrame
+
+ ^ LayoutFrame
+ fractions: (0 at 1 corner: 1 at 1)
+ offsets: (0@ self buttonHeight negated corner: 0 at 0)
+ !
Item was added:
+ ----- Method: FontImporterTool>>childrenOf: (in category 'accessing') -----
+ childrenOf: aFontDescription
+
+ ^ aFontDescription children!
Item was added:
+ ----- Method: FontImporterTool>>close (in category 'actions') -----
+ close
+ ToolBuilder default close: window.!
Item was added:
+ ----- Method: FontImporterTool>>contents (in category 'toolbuilder') -----
+ contents
+ | sample i c f |
+ sample := WriteStream on: ''.
+ f := self selectedFont ifNil:[^Text new].
+ (f isSymbolFont or: [(self font: f hasGlyphOf: $a) not]) ifFalse:[
+ sample
+ nextPutAll: 'the quick brown fox jumps over the lazy dog' ;cr;
+ nextPutAll: 'THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG.' ;cr;cr;
+ nextPutAll: '0123456789'; cr; cr;
+ nextPutAll:
+ 'Lorem ipsum dolor sit amet, consectetur adipisicing elit,
+ sed do eiusmod tempor incididunt ut labore et dolore
+ magna aliqua. Ut enim ad minim veniam, quis nostrud
+ exercitation ullamco laboris nisi ut aliquip ex ea commodo
+ consequat. Duis aute irure dolor in reprehenderit in voluptate
+ velit esse cillum dolore eu fugiat nulla pariatur. Excepteur
+ sint occaecat cupidatat non proident, sunt in culpa qui
+ officia deserunt mollit anim id est laborum.'
+ ] ifTrue:[
+ i := 0.
+ 33 to: 255 do:[:ci |
+ sample nextPut: (c:=Character value: ci).
+ i := i + 1.
+ (('@Z`z' includes:c) or:[i = 30])
+ ifTrue:[i :=0. sample cr]].
+ ].
+ sample := sample contents asText.
+ sample addAttribute: (TextFontReference toFont: f).
+ ^sample!
Item was added:
+ ----- Method: FontImporterTool>>copyright (in category 'toolbuilder') -----
+ copyright
+ | f |
+ f := self selectedFont ifNil:[^ ''].
+ ^ f isTTCFont
+ ifTrue: [f ttcDescription copyright ifNil: ['']]
+ ifFalse: ['']!
Item was added:
+ ----- Method: FontImporterTool>>currentParent (in category 'accessing') -----
+ currentParent
+
+ ^ currentParent!
Item was added:
+ ----- Method: FontImporterTool>>currentParent: (in category 'accessing') -----
+ currentParent: anObject
+
+ anObject = currentParent ifTrue: [^ self].
+ currentParent := anObject.
+ self changed: #currentParent.
+ !
Item was added:
+ ----- Method: FontImporterTool>>currentSelection (in category 'accessing') -----
+ currentSelection
+
+ ^ currentSelection!
Item was added:
+ ----- Method: FontImporterTool>>currentSelection: (in category 'accessing') -----
+ currentSelection: anObject
+
+ anObject = currentSelection ifTrue: [^ self].
+ currentSelection := anObject.
+ self changed: #currentSelection.
+ self changed: #contents.
+ self changed: #filename.
+ self changed: #copyright.!
Item was added:
+ ----- Method: FontImporterTool>>emphasis (in category 'accessing') -----
+ emphasis
+
+ ^ emphasis!
Item was added:
+ ----- Method: FontImporterTool>>emphasis: (in category 'accessing') -----
+ emphasis: anObject
+
+ emphasis := anObject!
Item was added:
+ ----- Method: FontImporterTool>>filename (in category 'toolbuilder') -----
+ filename
+
+ ^ self currentSelection
+ ifNil: ['']
+ ifNotNil: [:sel |
+ String streamContents: [:stream |
+ sel allFilenames
+ do: [:filename | stream nextPutAll: filename]
+ separatedBy: [stream nextPut: $,;nextPut: $ ]]]!
Item was added:
+ ----- Method: FontImporterTool>>font:hasGlyphOf: (in category 'toolbuilder') -----
+ font: f hasGlyphOf: aCharacter
+
+ ^ f isTTCFont
+ ifFalse: [f hasGlyphOf: aCharacter]
+ ifTrue: [
+ " [(f hasGlyphOf: aCharacter) not] does not work, the fallback glyph is always found instead.
+ So we fake. if aCharacter is the same form as Character null aka 0, we assume absence."
+ (f formOf: aCharacter) bits ~= f fallbackForm bits]
+ !
Item was added:
+ ----- Method: FontImporterTool>>fontFromFamily: (in category 'helper') -----
+ fontFromFamily: aFamily
+
+ | readFonts |
+ aFamily ifNil: [^ TextStyle default fonts first].
+ readFonts := TTFileDescription readFontsFrom: aFamily allFilenames anyOne.
+ ^ (readFonts size > 1
+ ifTrue: [
+ | ftArray |
+ " see TTCFontSet>>newTextStyleFromTT: "
+ ftArray := readFonts collect: [:ttc | |f|
+ ttc ifNil: [nil] ifNotNil: [
+ f := TTCFont new.
+ f ttcDescription: ttc.
+ f pointSize: 11.0 .
+ f]].
+ TTCFontSet newFontArray: ftArray]
+ ifFalse: [ |f|
+ f := TTCFont new.
+ f ttcDescription: readFonts anyOne.
+ f pointSize: 11.0 .
+ f])!
Item was added:
+ ----- Method: FontImporterTool>>fontListFrame (in category 'toolbuilder') -----
+ fontListFrame
+
+ ^ LayoutFrame
+ fractions: (0 at 0 corner: 0.4 at 1)
+ offsets: (0 at 0 corner: 0@ self buttonHeight negated + 4)!
Item was added:
+ ----- Method: FontImporterTool>>fontListMenu: (in category 'font list') -----
+ fontListMenu: aMenu
+
+ ^ aMenu addTranslatedList: #(
+ ('Import Font' import 'Include the font data in the image and provide a TextStyle for the font')
+ ('Link Font' link 'Install the font as a link to its file and provide a TextStyle for the referenced font'))
+ yourself!
Item was added:
+ ----- Method: FontImporterTool>>import (in category 'actions') -----
+ import
+ | megaSize filenames fonts |
+ fonts := self currentSelection.
+ filenames := fonts allFilenames.
+ megaSize := ((filenames inject: 0 into: [ :sum :fn |
+ sum + (FileStream readOnlyFileNamed: fn do: [:file | file size])]) / (1024 * 1024)) asFloat.
+ (UIManager default confirm: (
+ 'About to import {1}{2}.\\This is at least {3} MB of space required int the image.\
+ Please respect the copyright and embedding restrictions of the font.\
+ Proceed?'
+ withCRs format: {
+ self currentParent
+ ifNotNil: [:p| p fontname, ' ', self currentSelection fontname]
+ ifNil: [self currentSelection fontname].
+ filenames size > 1 ifTrue: [' (', filenames size, ' font files)'] ifFalse: [''].
+ megaSize printShowingDecimalPlaces: 2}))
+ ifTrue: [
+ filenames do: [:filename | | readFonts |
+ readFonts := TTCFontDescription addFromTTFile: filename.
+ readFonts isCollection
+ ifFalse: [TTCFont newTextStyleFromTT: readFonts]
+ ifTrue: [self importFontFamily: readFonts]]].
+ self allFonts: nil. "force redraw"
+ !
Item was added:
+ ----- Method: FontImporterTool>>importFontFamily: (in category 'helper') -----
+ importFontFamily: readFonts
+
+ |r rest array |
+ r := readFonts detect: [:f |
+ [f isRegular] on: Error do: [false] "hack for unknown emphases"
+ ] ifNone: [^ TTCFont newTextStyleFromTT: readFonts first].
+ rest := readFonts copyWithout: r.
+ array :=TTCFont pointSizes collect: [:pt | | f |
+ f := TTCFont new ttcDescription: r; pointSize: pt; yourself.
+ rest do: [:rf |
+ (self isStyleNameSupported: rf subfamilyName)
+ ifTrue: [f derivativeFont: (TTCFont new ttcDescription: rf; pointSize: pt; yourself)]
+ ifFalse: [
+ Transcript show: 'Cannot import unknown style ', rf subfamilyName, ' from Font family ', f name]].
+ f].
+ ^ TTCFont reorganizeForNewFontArray: array name: array first name asSymbol.!
Item was added:
+ ----- Method: FontImporterTool>>initialExtent (in category 'initialize') -----
+ initialExtent
+
+ ^ 600 at 400.!
Item was added:
+ ----- Method: FontImporterTool>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ title := 'Choose a Font to import'.
+ emphasis := 0.
+ !
Item was added:
+ ----- Method: FontImporterTool>>isStyleNameSupported: (in category 'helper') -----
+ isStyleNameSupported: subfamilyName
+
+ ^ (TextStyle decodeStyleName: subfamilyName) second isEmpty!
Item was added:
+ ----- Method: FontImporterTool>>labelOf: (in category 'accessing') -----
+ labelOf: aFontDescription
+
+ ^ aFontDescription fontname
+
+ !
Item was added:
+ ----- Method: FontImporterTool>>link (in category 'actions') -----
+ link
+ | filenames fonts |
+ fonts := self currentSelection.
+ self warningSeen ifFalse: [
+ (UIManager default confirm: (
+ 'Note that linking a font instead of importing may make the
+ image un-portable, since the linked font must be present on
+ the system the next time the image is run.
+
+ This warning is only shown once per session.' ) trueChoice: 'Proceed' falseChoice: 'Cancel')
+ ifFalse: [^ self].
+ self warningSeen: true]..
+ filenames := fonts allFilenames.
+ filenames do: [:filename | | readFonts |
+ readFonts := TTFileDescription readFontsFrom: filename.
+ readFonts isCollection
+ ifFalse: [TTCFont newTextStyleFromTT: readFonts]
+ ifTrue: [self importFontFamily: readFonts]].
+ self allFonts: nil. "force redraw"!
Item was added:
+ ----- Method: FontImporterTool>>open (in category 'toolbuilder') -----
+ open
+ ^ToolBuilder open: self!
Item was added:
+ ----- Method: FontImporterTool>>previewFrame (in category 'toolbuilder') -----
+ previewFrame
+
+ ^ LayoutFrame
+ fractions: (0.4 at 0 corner: 1 at 1)
+ offsets: (0 at 0 corner: 0@ self buttonHeight negated + 4)!
Item was added:
+ ----- Method: FontImporterTool>>selectedFont (in category 'font list') -----
+ selectedFont
+ | fontDesc font |
+ fontDesc := self currentSelection.
+ font := self fontFromFamily: fontDesc.
+ font isFontSet ifTrue: [
+ font := (self currentParent isNil or: [self currentParent = self currentSelection])
+ ifTrue: [font fontArray anyOne]
+ ifFalse: [ "we have selected a leaf "
+ font fontArray
+ detect: [:subfont | subfont subfamilyName = fontDesc fontname]
+ ifNone: [font]]].
+ ^font emphasized: emphasis!
Item was added:
+ ----- Method: FontImporterTool>>textForFamily:subfamily: (in category 'accessing') -----
+ textForFamily: familyName subfamily: subfamilyName
+
+ subfamilyName ifNil: [
+ ^ (TextStyle named: familyName)
+ ifNil: [familyName]
+ ifNotNil: [:style | style isTTCStyle
+ ifTrue: ["we are already present "
+ Text string: familyName attribute: TextEmphasis underlined]
+ ifFalse: [familyName]]].
+
+ " frome here on it is only about subfamilies"
+
+ (self isStyleNameSupported: subfamilyName)
+ ifFalse: [^ Text string: subfamilyName attribute: TextColor gray].
+
+ ^ (TextStyle named: familyName)
+ ifNil: ["importable" subfamilyName]
+ ifNotNil: [:style |
+ (style isTTCStyle and: [ | regular emph |
+ regular := style fonts anyOne.
+ emph := TTCFont indexOfSubfamilyName: subfamilyName.
+ " detect if this style is already imported "
+ regular emphasis = emph or: [(regular emphasis: emph) ~= regular]])
+ ifFalse: ["again importable" subfamilyName]
+ ifTrue: [Text string: subfamilyName attribute: TextEmphasis underlined]]!
Item was added:
+ ----- Method: FontImporterTool>>title (in category 'accessing') -----
+ title
+
+ ^ title!
Item was added:
+ ----- Method: FontImporterTool>>title: (in category 'accessing') -----
+ title: anObject
+ "Set the value of title"
+
+ title := anObject!
Item was added:
+ ----- Method: FontImporterTool>>warningSeen (in category 'accessing') -----
+ warningSeen
+
+ ^ warningSeen ifNil: [false]!
Item was added:
+ ----- Method: FontImporterTool>>warningSeen: (in category 'accessing') -----
+ warningSeen: anObject
+
+ warningSeen := anObject!
Item was added:
+ ----- Method: FontImporterTool>>window (in category 'accessing') -----
+ window
+ ^window!
Item was added:
+ ----- Method: FontImporterTool>>window: (in category 'accessing') -----
+ window: anObject
+
+ window := anObject!
Item was added:
+ ----- Method: FontImporterTool>>windowTitle (in category 'initialize') -----
+ windowTitle
+ ^ title translated!
Item was added:
+ ----- Method: Form>>asMorph (in category '*Morphic') -----
+ asMorph
+ ^ImageMorph new image: self!
Item was added:
+ ----- Method: Form>>iconOrThumbnailOfSize: (in category '*Morphic') -----
+ iconOrThumbnailOfSize: aNumberOrPoint
+ "Answer an appropiate form to represent the receiver"
+ ^ self scaledIntoFormOfSize: aNumberOrPoint!
Item was added:
+ ----- Method: Form>>scaledIntoFormOfSize: (in category '*Morphic') -----
+ scaledIntoFormOfSize: aNumberOrPoint
+ "Scale and center the receiver into a form of a given size"
+
+ | extent scale scaledForm result |
+
+ extent := aNumberOrPoint asPoint.
+ extent = self extent ifTrue: [^ self].
+
+ (self height isZero or: [self width isZero])
+ ifTrue: [^ Form extent: extent depth: self depth].
+
+ scale := extent y / self height min: extent x / self width.
+ scaledForm := self
+ magnify: self boundingBox
+ by: scale
+ smoothing: 8.
+
+ result := Form extent: extent depth: 32.
+ result getCanvas
+ translucentImage: scaledForm
+ at: extent - scaledForm extent // 2.
+
+ ^ result
+ !
Item was added:
+ ----- Method: Form>>stencil (in category '*Morphic-Support-image manipulation') -----
+ stencil
+ "return a 1-bit deep, black-and-white stencil of myself"
+
+ | canvas |
+ canvas := FormCanvas extent: self extent depth: 1.
+ canvas fillColor: (Color white).
+
+ canvas stencil: self at: 0 at 0
+ sourceRect: (Rectangle origin: 0 at 0 corner: self extent) color: Color black.
+
+ ^ canvas form
+ !
Item was added:
+ Canvas subclass: #FormCanvas
+ instanceVariableNames: 'origin clipRect form port shadowColor'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !FormCanvas commentStamp: '<historical>' prior: 0!
+ Note that when shadowDrawing is true, shadowStipple may be either a color, for a solid shadow of the given color, or it may be a stipple used to simulate gray shading when the display cannot support alpha blending.!
Item was added:
+ ----- Method: FormCanvas class>>extent: (in category 'instance creation') -----
+ extent: aPoint
+
+ ^ self extent: aPoint depth: Display depth
+ !
Item was added:
+ ----- Method: FormCanvas class>>extent:depth: (in category 'instance creation') -----
+ extent: extent depth: depth
+
+ ^ self new setForm: (Form extent: extent depth: depth)!
Item was added:
+ ----- Method: FormCanvas class>>extent:depth:origin:clipRect: (in category 'instance creation') -----
+ extent: extent depth: depth origin: aPoint clipRect: aRectangle
+
+ ^ self new
+ setForm: (Form extent: extent depth: depth);
+ setOrigin: aPoint clipRect: aRectangle;
+ yourself!
Item was added:
+ ----- Method: FormCanvas class>>on: (in category 'instance creation') -----
+ on: aForm
+
+ ^ self new setForm: aForm
+ !
Item was added:
+ ----- Method: FormCanvas class>>test1 (in category 'testing') -----
+ test1
+ "FormCanvas test1"
+
+ | canvas |
+ canvas := FormCanvas extent: 200 at 200.
+ canvas fillColor: (Color black).
+ canvas line: 10 at 10 to: 50 at 30 width: 1 color: (Color red).
+ canvas frameRectangle: ((20 at 20) corner: (120 at 120)) width: 4 color: (Color green).
+ canvas point: 100 at 100 color: (Color black).
+ canvas drawString: 'Hello, World!!' at: 40 at 40 font: nil color: (Color cyan).
+ canvas fillRectangle: ((10 at 80) corner: (31 at 121)) color: (Color magenta).
+ canvas fillOval: ((10 at 80) corner: (31 at 121)) color: (Color cyan).
+ canvas frameOval: ((40 at 80) corner: (61 at 121)) color: (Color blue).
+ canvas frameOval: ((70 at 80) corner: (91 at 121)) width: 3 color: (Color red alpha: 0.2).
+ canvas fillRectangle: ((130 at 30) corner: (170 at 80)) color: (Color lightYellow).
+ canvas showAt: 0 at 0.
+ !
Item was added:
+ ----- Method: FormCanvas class>>test2 (in category 'testing') -----
+ test2
+ "FormCanvas test2"
+
+ | baseCanvas p |
+ baseCanvas := FormCanvas extent: 200 at 200.
+ p := Sensor cursorPoint.
+ [Sensor anyButtonPressed] whileFalse: [
+ baseCanvas translateBy: (Sensor cursorPoint - p) during:[:canvas|
+ canvas fillColor: Color white.
+ canvas line: 10 at 10 to: 50 at 30 width: 1 color: Color red.
+ canvas frameRectangle: ((20 at 20) corner: (120 at 120)) width: 4 color: Color green.
+ canvas point: 100 at 100 color: Color black.
+ canvas drawString: 'Hello, World!!' at: 40 at 40 font: nil color: Color cyan.
+ canvas fillRectangle: ((10 at 80) corner: (31 at 121)) color: Color magenta.
+ canvas fillOval: ((10 at 80) corner: (31 at 121)) color: Color cyan.
+ canvas frameOval: ((40 at 80) corner: (61 at 121)) color: Color blue.
+ canvas frameOval: ((70 at 80) corner: (91 at 121)) width: 3 color: Color red.
+ canvas fillRectangle: ((130 at 30) corner: (170 at 80)) color: Color lightYellow.
+ canvas showAt: 0 at 0]].
+ !
Item was added:
+ ----- Method: FormCanvas class>>test3 (in category 'testing') -----
+ test3
+ "FormCanvas test3"
+
+ | baseCanvas |
+ baseCanvas := FormCanvas extent: 200 at 200.
+ baseCanvas fillColor: Color white.
+ baseCanvas translateBy: 10 at 10 during:[:canvas|
+ canvas shadowColor: (Color black alpha: 0.5).
+ canvas line: 10 at 10 to: 50 at 30 width: 1 color: Color red.
+ canvas frameRectangle: ((20 at 20) corner: (120 at 120)) width: 4 color: Color green.
+ canvas point: 100 at 100 color: Color black.
+ canvas drawString: 'Hello, World!!' at: 40 at 40 font: nil color: Color cyan.
+ canvas fillRectangle: ((10 at 80) corner: (31 at 121)) color: Color magenta.
+ canvas fillOval: ((10 at 80) corner: (31 at 121)) color: Color cyan.
+ canvas frameOval: ((40 at 80) corner: (61 at 121)) color: Color blue.
+ canvas frameOval: ((70 at 80) corner: (91 at 121)) width: 3 color: Color red.
+ canvas fillRectangle: ((130 at 30) corner: (170 at 80)) color: Color lightYellow.
+ canvas showAt: 0 at 0.
+ ].!
Item was added:
+ ----- Method: FormCanvas>>allocateForm: (in category 'accessing') -----
+ allocateForm: extentPoint
+ "Allocate a new form which is similar to the receiver"
+ ^form allocateForm: extentPoint!
Item was added:
+ ----- Method: FormCanvas>>asBalloonCanvas (in category 'other') -----
+ asBalloonCanvas
+ ^(BalloonCanvas on: form) setOrigin: origin clipRect: clipRect!
Item was added:
+ ----- Method: FormCanvas>>asShadowDrawingCanvas (in category 'converting') -----
+ asShadowDrawingCanvas
+ "Note: This is sort of an optimization here since since the logic is all there"
+ ^self copy shadowColor: (Color black alpha: 0.5)!
Item was added:
+ ----- Method: FormCanvas>>asShadowDrawingCanvas: (in category 'converting') -----
+ asShadowDrawingCanvas: aColor
+ "Note: This is sort of an optimization here since since the logic is all there"
+ ^self copy shadowColor: aColor!
Item was added:
+ ----- Method: FormCanvas>>balloonFillOval:fillStyle:borderWidth:borderColor: (in category 'drawing-ovals') -----
+ balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
+
+ self asBalloonCanvas
+ fillOval: aRectangle
+ fillStyle: aFillStyle
+ borderWidth: bw
+ borderColor: bc!
Item was added:
+ ----- Method: FormCanvas>>balloonFillRectangle:fillStyle: (in category 'private') -----
+ balloonFillRectangle: aRectangle fillStyle: aFillStyle
+
+ self asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle.!
Item was added:
+ ----- Method: FormCanvas>>balloonFillRoundRect:radius:fillStyle: (in category 'private') -----
+ balloonFillRoundRect: aRectangle radius: radius fillStyle: fillStyle
+ ^self asBalloonCanvas fillRoundRect: aRectangle radius: radius fillStyle: fillStyle!
Item was added:
+ ----- Method: FormCanvas>>clipBy:during: (in category 'drawing-support') -----
+ clipBy: aRectangle during: aBlock
+ "Set a clipping rectangle active only during the execution of aBlock.
+ Note: In the future we may want to have more general clip shapes - not just rectangles"
+ ^aBlock value: (self copyClipRect: aRectangle)!
Item was added:
+ ----- Method: FormCanvas>>clipRect (in category 'accessing') -----
+ clipRect
+ "Return the currently active clipping rectangle"
+ ^ clipRect translateBy: origin negated!
Item was added:
+ ----- Method: FormCanvas>>contentsOfArea:into: (in category 'accessing') -----
+ contentsOfArea: aRectangle into: aForm
+ | bb |
+ self flush.
+ bb := BitBlt toForm: aForm.
+ bb sourceForm: form; combinationRule: Form over;
+ sourceX: (aRectangle left + origin x); sourceY: (aRectangle top + origin y);
+ width: aRectangle width; height: aRectangle height;
+ copyBits.
+ ^aForm!
Item was added:
+ ----- Method: FormCanvas>>copy (in category 'copying') -----
+ copy
+ "Make a copy the receiver on the same underlying Form but with its own grafPort."
+
+ ^ self clone resetGrafPort
+ !
Item was added:
+ ----- Method: FormCanvas>>copyClipRect: (in category 'copying') -----
+ copyClipRect: aRectangle
+ ^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin)
+ !
Item was added:
+ ----- Method: FormCanvas>>copyOffset: (in category 'copying') -----
+ copyOffset: aPoint
+ ^ self copyOrigin: origin + aPoint clipRect: clipRect!
Item was added:
+ ----- Method: FormCanvas>>copyOffset:clipRect: (in category 'copying') -----
+ copyOffset: aPoint clipRect: sourceClip
+ "Make a copy of me offset by aPoint, and further clipped
+ by sourceClip, a rectangle in the un-offset coordinates"
+ ^ self copyOrigin: aPoint + origin
+ clipRect: ((sourceClip translateBy: origin) intersect: clipRect)!
Item was added:
+ ----- Method: FormCanvas>>copyOrigin:clipRect: (in category 'copying') -----
+ copyOrigin: aPoint clipRect: aRectangle
+ "Return a copy of this canvas with the given origin. The clipping rectangle of this canvas is the intersection of the given rectangle and the receiver's current clipping rectangle. This allows the clipping rectangles of nested clipping morphs to be composed."
+ ^ self copy
+ setOrigin: aPoint
+ clipRect: (clipRect intersect: aRectangle)!
Item was added:
+ ----- Method: FormCanvas>>depth (in category 'accessing') -----
+ depth
+
+ ^ form depth
+ !
Item was added:
+ ----- Method: FormCanvas>>drawPolygon:color:borderWidth:borderColor: (in category 'drawing-polygons') -----
+ drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
+ "Generalize for the BalloonCanvas"
+ ^self drawPolygon: vertices fillStyle: aColor borderWidth: bw borderColor: bc!
Item was added:
+ ----- Method: FormCanvas>>drawPolygon:fillStyle:borderWidth:borderColor: (in category 'drawing-polygons') -----
+ drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc
+ "Use a BalloonCanvas"
+ self asBalloonCanvas
+ drawPolygon: vertices asArray
+ fillStyle: (self shadowColor ifNil:[aFillStyle])
+ borderWidth: bw
+ borderColor: bc!
Item was added:
+ ----- Method: FormCanvas>>drawString:from:to:at:font:color: (in category 'drawing-text') -----
+ drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: c
+ | font |
+ port colorMap: nil.
+ font := fontOrNil ifNil: [TextStyle defaultFont].
+ port combinationRule: Form paint.
+ font installOn: port
+ foregroundColor: (self shadowColor ifNil:[c])
+ backgroundColor: Color transparent.
+ font displayString: aString on: port
+ from: firstIndex to: lastIndex at: (origin + aPoint) kern: 0.!
Item was added:
+ ----- Method: FormCanvas>>drawString:from:to:in:font:color: (in category 'drawing-text') -----
+ drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c
+ | font portRect |
+ port colorMap: nil.
+ portRect := port clipRect.
+ port clipByX1: bounds left + origin x
+ y1: bounds top + origin y
+ x2: bounds right + origin x
+ y2: bounds bottom + origin y.
+ font := fontOrNil ifNil: [TextStyle defaultFont].
+ port combinationRule: Form paint.
+ font installOn: port
+ foregroundColor: (self shadowColor ifNil:[c])
+ backgroundColor: Color transparent.
+ font displayString: aString asString on: port
+ from: firstIndex to: lastIndex at: (bounds topLeft + origin) kern: 0.
+ port clipRect: portRect.!
Item was added:
+ ----- Method: FormCanvas>>extent (in category 'accessing') -----
+ extent
+
+ ^ form extent!
Item was added:
+ ----- Method: FormCanvas>>fillColor: (in category 'drawing') -----
+ fillColor: c
+ "Note: This always fills, even if the color is transparent."
+ self setClearColor: c.
+ port fillRect: form boundingBox offset: origin.!
Item was added:
+ ----- Method: FormCanvas>>fillOval:color:borderWidth:borderColor: (in category 'drawing-ovals') -----
+ fillOval: r color: fillColor borderWidth: borderWidth borderColor: borderColor
+ | rect |
+ "draw the border of the oval"
+ rect := (r translateBy: origin) truncated.
+ (borderWidth = 0 or: [borderColor isTransparent]) ifFalse:[
+ self setFillColor: borderColor.
+ (r area > 10000 or: [fillColor isTranslucent])
+ ifTrue: [port frameOval: rect borderWidth: borderWidth]
+ ifFalse: [port fillOval: rect]]. "faster this way"
+ "fill the inside"
+ fillColor isTransparent ifFalse:
+ [self setFillColor: fillColor.
+ port fillOval: (rect insetBy: borderWidth)].
+ !
Item was added:
+ ----- Method: FormCanvas>>fillOval:fillStyle:borderWidth:borderColor: (in category 'drawing-ovals') -----
+ fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
+ "Fill the given oval."
+
+ self flag: #bob. "this and its siblings could be moved up to Canvas with the
+ right #balloonFillOval:..."
+
+ self shadowColor ifNotNil:
+ [^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
+ (aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
+ self flag: #fixThis.
+ ^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc].
+ (aFillStyle isSolidFill) ifTrue:[
+ ^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
+ "Use a BalloonCanvas instead"
+ self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc!
Item was added:
+ ----- Method: FormCanvas>>fillRectangle:fillStyle: (in category 'drawing-rectangles') -----
+ fillRectangle: aRectangle fillStyle: aFillStyle
+ "Fill the given rectangle."
+ | pattern |
+ self shadowColor ifNotNil:
+ [^self fillRectangle: aRectangle color: aFillStyle asColor].
+
+ (aFillStyle isKindOf: InfiniteForm) ifTrue: [
+ ^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
+ ].
+
+ (aFillStyle isSolidFill)
+ ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor].
+ "We have a very special case for filling with infinite forms"
+ (aFillStyle isBitmapFill and:[aFillStyle origin = (0 at 0)]) ifTrue:[
+ pattern := aFillStyle form.
+ (aFillStyle direction = (pattern width @ 0)
+ and:[aFillStyle normal = (0 at pattern height)]) ifTrue:[
+ "Can use an InfiniteForm"
+ ^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
+ ].
+ "Use a BalloonCanvas instead"
+ self balloonFillRectangle: aRectangle fillStyle: aFillStyle.!
Item was added:
+ ----- Method: FormCanvas>>fillRoundRect:radius:fillStyle: (in category 'drawing-rectangles') -----
+ fillRoundRect: aRectangle radius: radius fillStyle: fillStyle
+ fillStyle isTransparent ifTrue:[^self].
+ radius asPoint <= (0 at 0)
+ ifTrue:[^self fillRectangle: aRectangle fillStyle: fillStyle].
+ (radius * 2) asPoint >= aRectangle extent
+ ifTrue:[^self fillOval: aRectangle fillStyle: fillStyle].
+ fillStyle isSolidFill
+ ifFalse:[^self balloonFillRoundRect: aRectangle radius: radius fillStyle: fillStyle].
+ self setFillColor: (shadowColor ifNil:[fillStyle asColor]).
+ ^port fillRoundRect: (aRectangle translateBy: origin) truncated radius: radius.
+ !
Item was added:
+ ----- Method: FormCanvas>>finish (in category 'initialization') -----
+ finish
+ "If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."
+ form finish!
Item was added:
+ ----- Method: FormCanvas>>flushDisplay (in category 'other') -----
+ flushDisplay
+ Display deferUpdates: false; forceDisplayUpdate.!
Item was added:
+ ----- Method: FormCanvas>>forceToScreen: (in category 'other') -----
+ forceToScreen:rect
+ ^Display forceToScreen:rect.
+ !
Item was added:
+ ----- Method: FormCanvas>>form (in category 'accessing') -----
+ form
+
+ ^ form!
Item was added:
+ ----- Method: FormCanvas>>frameAndFillRectangle:fillColor:borderWidth:borderColor: (in category 'drawing-rectangles') -----
+ frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
+ | rect |
+ rect := r translateBy: origin.
+ "draw the border of the rectangle"
+ borderColor isTransparent ifFalse:[
+ self setFillColor: borderColor.
+ (r area > 10000 or: [fillColor isTranslucent]) ifTrue: [
+ port frameRect: rect borderWidth: borderWidth.
+ ] ifFalse: ["for small rectangles, it's faster to fill the entire outer rectangle
+ than to compute and fill the border rects"
+ port fillRect: rect offset: origin]].
+
+ "fill the inside"
+ fillColor isTransparent ifFalse:
+ [self setFillColor: fillColor.
+ port fillRect: (rect insetBy: borderWidth) offset: origin].!
Item was added:
+ ----- Method: FormCanvas>>frameAndFillRectangle:fillColor:borderWidth:topLeftColor:bottomRightColor: (in category 'drawing-rectangles') -----
+ frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
+
+ | w h rect |
+ "First use quick code for top and left borders and fill"
+ self frameAndFillRectangle: r
+ fillColor: fillColor
+ borderWidth: borderWidth
+ borderColor: topLeftColor.
+
+ "Now use slow code for bevelled bottom and right borders"
+ bottomRightColor isTransparent ifFalse: [
+ borderWidth isNumber
+ ifTrue: [w := h := borderWidth]
+ ifFalse: [w := borderWidth x. h := borderWidth y].
+ rect := r translateBy: origin.
+ self setFillColor: bottomRightColor.
+ port
+ frameRectRight: rect width: w;
+ frameRectBottom: rect height: h].
+ !
Item was added:
+ ----- Method: FormCanvas>>frameAndFillRoundRect:radius:fillStyle:borderWidth:borderColor: (in category 'drawing-rectangles') -----
+ frameAndFillRoundRect: aRectangle radius: cornerRadius fillStyle: fillStyle borderWidth: bw borderColor: bc
+ "Draw a rounded rectangle"
+ self shadowColor ifNotNil:[
+ ^self fillRoundRect: aRectangle radius: cornerRadius fillStyle: shadowColor.
+ ].
+ "see if the round rect is degenerate"
+ cornerRadius asPoint <= (0 at 0)
+ ifTrue:[^self frameAndFillRectangle: aRectangle fillColor: fillStyle asColor borderWidth: bw borderColor: bc].
+ cornerRadius * 2 >= aRectangle width
+ ifTrue:[^self fillOval: aRectangle color: fillStyle asColor borderWidth: bw borderColor: bc].
+ "Okay it's a rounded rectangle"
+ fillStyle isTransparent ifFalse:["fill interior"
+ | innerRect radius |
+ innerRect := aRectangle.
+ radius := cornerRadius.
+ bw isZero ifFalse:[
+ innerRect := innerRect insetBy: bw.
+ radius := radius - bw.
+ ].
+ self fillRoundRect: innerRect radius: radius fillStyle: fillStyle.
+ ].
+ self frameRoundRect: aRectangle radius: cornerRadius width: bw color: bc
+ !
Item was added:
+ ----- Method: FormCanvas>>frameRoundRect:radius:width:color: (in category 'drawing-rectangles') -----
+ frameRoundRect: aRectangle radius: radius width: borderWidth color: borderColor
+ "Frame a rounded rectangle with the given attributes."
+ | innerRect |
+ (borderWidth isZero or:[borderColor isTransparent])
+ ifTrue:[^self].
+ radius asPoint <= (0 at 0)
+ ifTrue:[^self frameRectangle: aRectangle width: borderWidth color: borderColor].
+ (radius * 2) asPoint >= aRectangle extent
+ ifTrue:[^self frameOval: aRectangle width: borderWidth color: borderColor].
+ "decompose inner rectangle into bezier shape"
+ innerRect := aRectangle insetBy: borderWidth.
+ innerRect area <= 0
+ ifTrue:[^self fillRoundRect: aRectangle radius: radius fillStyle: borderColor].
+ self setFillColor: borderColor.
+ port
+ frameRoundRect: (aRectangle translateBy: origin) truncated
+ radius: radius truncated
+ borderWidth: borderWidth truncated.
+ !
Item was added:
+ ----- Method: FormCanvas>>image:at:sourceRect:rule: (in category 'private') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule
+ "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."
+ port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil.
+ port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule.
+ (form depth = 32 and: [aForm depth = 16])
+ ifTrue: [port image: nil at: aPoint + origin sourceRect: sourceRect rule: 40 "fixAlpha:with:"].
+ !
Item was added:
+ ----- Method: FormCanvas>>image:at:sourceRect:rule:alpha: (in category 'private') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha
+ "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."
+ port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil.
+ port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule alpha: sourceAlpha.!
Item was added:
+ ----- Method: FormCanvas>>infiniteFillRectangle:fillStyle: (in category 'private') -----
+ infiniteFillRectangle: aRectangle fillStyle: aFillStyle
+
+ | additionalOffset rInPortTerms clippedPort targetTopLeft clipOffset ex |
+
+ "this is a bit of a kludge to get the form to be aligned where I *think* it should be.
+ something better is needed, but not now"
+
+ additionalOffset := 0 at 0.
+ ex := aFillStyle form extent.
+ rInPortTerms := aRectangle translateBy: origin.
+ clippedPort := port clippedBy: rInPortTerms.
+ targetTopLeft := clippedPort clipRect topLeft truncateTo: ex.
+ clipOffset := rInPortTerms topLeft - targetTopLeft.
+ additionalOffset := (clipOffset \\ ex) - ex.
+ ^aFillStyle
+ displayOnPort: clippedPort
+ offsetBy: additionalOffset
+ !
Item was added:
+ ----- Method: FormCanvas>>isShadowDrawing (in category 'testing') -----
+ isShadowDrawing
+ ^ self shadowColor notNil!
Item was added:
+ ----- Method: FormCanvas>>isVisible: (in category 'testing') -----
+ isVisible: aRectangle
+ "Optimization"
+ (aRectangle right + origin x) < clipRect left ifTrue: [^ false].
+ (aRectangle left + origin x) > clipRect right ifTrue: [^ false].
+ (aRectangle bottom + origin y) < clipRect top ifTrue: [^ false].
+ (aRectangle top + origin y) > clipRect bottom ifTrue: [^ false].
+ ^ true
+ !
Item was added:
+ ----- Method: FormCanvas>>line:to:brushForm: (in category 'drawing') -----
+ line: pt1 to: pt2 brushForm: brush
+ | offset |
+ offset := origin.
+ self setPaintColor: Color black.
+ port sourceForm: brush; fillColor: nil;
+ sourceRect: brush boundingBox;
+ colorMap: (brush colormapIfNeededFor: form);
+ drawFrom: (pt1 + offset) to: (pt2 + offset)!
Item was added:
+ ----- Method: FormCanvas>>line:to:width:color: (in category 'drawing') -----
+ line: pt1 to: pt2 width: w color: c
+ | offset |
+ offset := origin - (w // 2) asPoint.
+ self setFillColor: c.
+ port width: w; height: w;
+ drawFrom: (pt1 + offset) to: (pt2 + offset)!
Item was added:
+ ----- Method: FormCanvas>>origin (in category 'accessing') -----
+ origin
+ "Return the current origin for drawing operations"
+ ^ origin!
Item was added:
+ ----- Method: FormCanvas>>paragraph:bounds:color: (in category 'drawing') -----
+ paragraph: para bounds: bounds color: c
+
+ | scanner |
+ self setPaintColor: c.
+ scanner := (port clippedBy: (bounds translateBy: origin)) displayScannerFor: para
+ foreground: (self shadowColor ifNil:[c]) background: Color transparent
+ ignoreColorChanges: self shadowColor notNil.
+ para displayOn: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft.
+ !
Item was added:
+ ----- Method: FormCanvas>>point:color: (in category 'drawing') -----
+ point: pt color: c
+
+ form colorAt: (pt + origin) put: c.!
Item was added:
+ ----- Method: FormCanvas>>portClass (in category 'private') -----
+ portClass
+ "Return the class used as port"
+ ^BitBlt asGrafPort!
Item was added:
+ ----- Method: FormCanvas>>printOn: (in category 'printing') -----
+ printOn: aStream
+ super printOn: aStream.
+ aStream nextPutAll:' on: '; print: form.!
Item was added:
+ ----- Method: FormCanvas>>privateClipRect (in category 'private') -----
+ privateClipRect
+
+ ^clipRect!
Item was added:
+ ----- Method: FormCanvas>>privatePort (in category 'private') -----
+ privatePort
+
+ ^port!
Item was added:
+ ----- Method: FormCanvas>>privateWarp:transform:at:sourceRect:cellSize: (in category 'private') -----
+ privateWarp: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize
+ "Warp the given using the appropriate transform and offset."
+ | globalRect sourceQuad warp tfm |
+ tfm := aTransform.
+ globalRect := tfm localBoundsToGlobal: sourceRect.
+ sourceQuad := (tfm sourceQuadFor: globalRect) collect:[:p| p - sourceRect topLeft].
+ extraOffset ifNotNil:[globalRect := globalRect translateBy: extraOffset].
+ warp := (WarpBlt toForm: port destForm)
+ combinationRule: Form paint;
+ sourceQuad: sourceQuad destRect: (globalRect origin corner: globalRect corner+(1 at 1));
+ clipRect: port clipRect.
+ warp cellSize: cellSize.
+ warp sourceForm: aForm.
+ warp warpBits!
Item was added:
+ ----- Method: FormCanvas>>render: (in category 'drawing') -----
+ render: anObject
+ "Do some 3D operations with the object if possible"
+ ^self asBalloonCanvas render: anObject!
Item was added:
+ ----- Method: FormCanvas>>reset (in category 'initialization') -----
+ reset
+
+ origin := 0 at 0. "origin of the top-left corner of this cavas"
+ form ifNil:[
+ "This code path will never be executed after the changes in setForm:
+ are installed, so it can be removed in due time."
+ clipRect := (0 at 0 corner: 10000 at 10000).
+ ] ifNotNil:[
+ clipRect := (0 at 0 corner: form extent). "default clipping rectangle"
+ ].
+ self shadowColor: nil.!
Item was added:
+ ----- Method: FormCanvas>>resetGrafPort (in category 'private') -----
+ resetGrafPort
+ "Private!! Create a new grafPort for a new copy."
+
+ port := self portClass toForm: form.
+ port clipRect: clipRect.
+ !
Item was added:
+ ----- Method: FormCanvas>>setClearColor: (in category 'private') -----
+ setClearColor: aColor
+ "Install a new clear color - e.g., a color is used for clearing the background"
+ | clearColor |
+ clearColor := aColor ifNil:[Color transparent].
+ clearColor isColor ifFalse:[
+ (clearColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
+ ^port fillPattern: clearColor; combinationRule: Form over].
+ "Okay, so clearColor really *is* a color"
+ port sourceForm: nil.
+ port combinationRule: Form over.
+ port fillPattern: clearColor.
+ self depth = 8 ifTrue:[
+ "Use a stipple pattern"
+ port fillColor: (form balancedPatternFor: clearColor)].
+ !
Item was added:
+ ----- Method: FormCanvas>>setFillColor: (in category 'private') -----
+ setFillColor: aColor
+ "Install a new color used for filling."
+ | screen patternWord fillColor |
+ fillColor := self shadowColor ifNil:[aColor].
+ fillColor ifNil:[fillColor := Color transparent].
+ fillColor isColor ifFalse:[
+ (fillColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
+ ^port fillPattern: fillColor; combinationRule: Form over].
+ "Okay, so fillColor really *is* a color"
+ port sourceForm: nil.
+ fillColor isTranslucent ifFalse:[
+ port combinationRule: Form over.
+ port fillPattern: fillColor.
+ self depth = 8 ifTrue:[
+ "In 8 bit depth it's usually a good idea to use a stipple pattern"
+ port fillColor: (form balancedPatternFor: fillColor)].
+ ^self].
+ "fillColor is some translucent color"
+
+ self depth > 8 ifTrue:[
+ "BitBlt setup for alpha masked transfer"
+ port fillPattern: fillColor.
+ self depth = 16
+ ifTrue:[port alphaBits: fillColor privateAlpha; combinationRule: 30]
+ ifFalse:[port combinationRule: Form blend].
+ ^self].
+ "Can't represent actual transparency -- use stipple pattern"
+ screen := Color translucentMaskFor: fillColor alpha depth: self depth.
+ patternWord := form pixelWordFor: fillColor.
+ port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
+ port combinationRule: Form paint.
+ !
Item was added:
+ ----- Method: FormCanvas>>setForm: (in category 'private') -----
+ setForm: aForm
+
+ form := aForm.
+ port := self portClass toForm: form.
+ self reset.!
Item was added:
+ ----- Method: FormCanvas>>setOrigin:clipRect: (in category 'private') -----
+ setOrigin: aPoint clipRect: aRectangle
+
+ origin := aPoint.
+ clipRect := aRectangle.
+ port clipRect: aRectangle.
+ !
Item was added:
+ ----- Method: FormCanvas>>setPaintColor: (in category 'private') -----
+ setPaintColor: aColor
+ "Install a new color used for filling."
+ | paintColor screen patternWord |
+ paintColor := self shadowColor ifNil:[aColor].
+ paintColor ifNil:[paintColor := Color transparent].
+ paintColor isColor ifFalse:[
+ (paintColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
+ ^port fillPattern: paintColor; combinationRule: Form paint].
+ "Okay, so paintColor really *is* a color"
+ port sourceForm: nil.
+ (paintColor isTranslucent) ifFalse:[
+ port fillPattern: paintColor.
+ port combinationRule: Form paint.
+ self depth = 8 ifTrue:[
+ port fillColor: (form balancedPatternFor: paintColor)].
+ ^self].
+ "paintColor is translucent color"
+
+ self depth > 8 ifTrue:[
+ "BitBlt setup for alpha mapped transfer"
+ port fillPattern: paintColor.
+ self depth = 16
+ ifTrue:[port alphaBits: paintColor privateAlpha; combinationRule: 31]
+ ifFalse:[port combinationRule: Form blend].
+ ^self].
+
+ "Can't represent actual transparency -- use stipple pattern"
+ screen := Color translucentMaskFor: paintColor alpha depth: self depth.
+ patternWord := form pixelWordFor: paintColor.
+ port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
+ port combinationRule: Form paint
+ !
Item was added:
+ ----- Method: FormCanvas>>shadowColor (in category 'accessing') -----
+ shadowColor
+ ^shadowColor!
Item was added:
+ ----- Method: FormCanvas>>shadowColor: (in category 'accessing') -----
+ shadowColor: aColor
+ shadowColor := aColor!
Item was added:
+ ----- Method: FormCanvas>>showAt: (in category 'other') -----
+ showAt: pt
+
+ ^ form displayAt: pt!
Item was added:
+ ----- Method: FormCanvas>>showAt:invalidRects: (in category 'other') -----
+ showAt: pt invalidRects: updateRects
+ | blt |
+ blt := (BitBlt toForm: Display)
+ sourceForm: form;
+ combinationRule: Form over.
+ updateRects do:
+ [:rect |
+ blt sourceRect: rect;
+ destOrigin: rect topLeft + pt;
+ copyBits]!
Item was added:
+ ----- Method: FormCanvas>>stencil:at:sourceRect:color: (in category 'drawing-images') -----
+ stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
+ "Flood this canvas with aColor wherever stencilForm has non-zero pixels"
+ self setPaintColor: aColor.
+ port colorMap: stencilForm maskingMap.
+ port stencil: stencilForm
+ at: aPoint + origin
+ sourceRect: sourceRect.!
Item was added:
+ ----- Method: FormCanvas>>transformBy:clippingTo:during:smoothing: (in category 'drawing-support') -----
+ transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
+
+ "Note: This method has been originally copied from TransformationMorph."
+ | innerRect patchRect sourceQuad warp start subCanvas |
+ (aDisplayTransform isPureTranslation) ifTrue:[
+ ^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated
+ clipRect: aClipRect)
+ ].
+ "Prepare an appropriate warp from patch to innerRect"
+ innerRect := aClipRect.
+ patchRect := (aDisplayTransform globalBoundsToLocal: innerRect) truncated.
+ sourceQuad := (aDisplayTransform sourceQuadFor: innerRect)
+ collect: [:p | p - patchRect topLeft].
+ warp := self warpFrom: sourceQuad toRect: innerRect.
+
+ "Render the submorphs visible in the clipping rectangle, as patchForm"
+ start := (self depth = 1 and: [self isShadowDrawing not])
+ "If this is true B&W, then we need a first pass for erasure."
+ ifTrue: [1] ifFalse: [2].
+ start to: 2 do:
+ [:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W"
+ subCanvas := self class extent: patchRect extent depth: self depth.
+ i=1 ifTrue: [subCanvas shadowColor: Color black.
+ warp combinationRule: Form erase]
+ ifFalse: [self isShadowDrawing ifTrue:
+ [subCanvas shadowColor: self shadowColor].
+ warp combinationRule: (self depth = 32
+ ifTrue: [Form blendAlphaScaled]
+ ifFalse: [Form paint])].
+ subCanvas
+ translateBy: patchRect topLeft negated
+ during: aBlock.
+ warp sourceForm: subCanvas form; cellSize: cellSize; warpBits.
+ warp sourceForm: nil. subCanvas := nil "release space for next loop"]
+ !
Item was added:
+ ----- Method: FormCanvas>>translateBy:during: (in category 'drawing-support') -----
+ translateBy: delta during: aBlock
+ "Set a translation only during the execution of aBlock."
+ ^aBlock value: (self copyOffset: delta)!
Item was added:
+ ----- Method: FormCanvas>>translateTo:clippingTo:during: (in category 'drawing-support') -----
+ translateTo: newOrigin clippingTo: aRectangle during: aBlock
+ "Set a new origin and clipping rectangle only during the execution of aBlock."
+ aBlock value: (self copyOrigin: newOrigin clipRect: aRectangle)!
Item was added:
+ ----- Method: FormCanvas>>warpFrom:toRect: (in category 'other') -----
+ warpFrom: sourceQuad toRect: destRect
+ ^ (WarpBlt toForm: port destForm)
+ combinationRule: Form paint;
+ sourceQuad: sourceQuad destRect: (destRect translateBy: origin);
+ clipRect: clipRect!
Item was added:
+ ----- Method: FormCanvas>>warpImage:transform:at:sourceRect:cellSize: (in category 'drawing-images') -----
+ warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize
+ "Warp the given using the appropriate transform and offset."
+ | tfm |
+ tfm := (MatrixTransform2x3 withOffset: origin) composedWithLocal: aTransform.
+ ^self privateWarp: aForm transform: tfm at: extraOffset sourceRect: sourceRect cellSize: cellSize!
Item was added:
+ ----- Method: GradientFillStyle>>addFillStyleMenuItems:hand:from: (in category '*Morphic-Balloon') -----
+ addFillStyleMenuItems: aMenu hand: aHand from: aMorph
+ "Add the items for changing the current fill style of the receiver"
+ self isRadialFill ifTrue:[
+ aMenu add: 'linear gradient' translated target: self selector: #beLinearGradientIn: argument: aMorph.
+ ] ifFalse:[
+ aMenu add: 'radial gradient' translated target: self selector: #beRadialGradientIn: argument: aMorph.
+ ].
+ aMenu addLine.
+ aMenu add: 'change first color' translated target: self selector: #changeFirstColorIn:event: argument: aMorph.
+ aMenu add: 'change second color' translated target: self selector: #changeSecondColorIn:event: argument: aMorph.
+ aMenu addLine.
+ super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.!
Item was added:
+ ----- Method: GradientFillStyle>>addNewColorIn:event: (in category '*Morphic-Balloon') -----
+ addNewColorIn: aMorph event: evt
+ ^self inform:'not yet implemented'!
Item was added:
+ ----- Method: GradientFillStyle>>beLinearGradientIn: (in category '*Morphic-Balloon') -----
+ beLinearGradientIn: aMorph
+ self radial: false.
+ aMorph changed.!
Item was added:
+ ----- Method: GradientFillStyle>>beRadialGradientIn: (in category '*Morphic-Balloon') -----
+ beRadialGradientIn: aMorph
+ self radial: true.
+ aMorph changed.!
Item was added:
+ ----- Method: GradientFillStyle>>changeColorSelector:hand:morph:originalColor: (in category '*Morphic-Balloon') -----
+ changeColorSelector: aSymbol hand: aHand morph: aMorph originalColor: originalColor
+ "Change either the firstColor or the lastColor (depending on aSymbol). Put up a color picker to hande it. We always use a modal picker so that the user can adjust both colors concurrently."
+ NewColorPickerMorph useIt
+ ifTrue:
+ [ (NewColorPickerMorph
+ on: self
+ originalColor: originalColor
+ setColorSelector: aSymbol) openNear: aMorph fullBoundsInWorld ]
+ ifFalse:
+ [ ColorPickerMorph new
+ initializeModal: false ;
+ sourceHand: aHand ;
+ target: self ;
+ selector: aSymbol ;
+ argument: aMorph ;
+ originalColor: originalColor ;
+
+ putUpFor: aMorph
+ near: aMorph fullBoundsInWorld ]!
Item was added:
+ ----- Method: GradientFillStyle>>changeFirstColorIn:event: (in category '*Morphic-Balloon') -----
+ changeFirstColorIn: aMorph event: evt
+ ^self changeColorSelector: #firstColor:forMorph:hand: hand: evt hand morph: aMorph originalColor: colorRamp first value!
Item was added:
+ ----- Method: GradientFillStyle>>changeSecondColorIn:event: (in category '*Morphic-Balloon') -----
+ changeSecondColorIn: aMorph event: evt
+ ^self changeColorSelector: #lastColor:forMorph:hand: hand: evt hand morph: aMorph originalColor: colorRamp last value!
Item was added:
+ ----- Method: GradientFillStyle>>firstColor:forMorph:hand: (in category '*Morphic-Balloon') -----
+ firstColor: aColor forMorph: aMorph hand: aHand
+ colorRamp first value: aColor.
+ isTranslucent := nil.
+ pixelRamp := nil.
+ aMorph changed.!
Item was added:
+ ----- Method: GradientFillStyle>>lastColor:forMorph:hand: (in category '*Morphic-Balloon') -----
+ lastColor: aColor forMorph: aMorph hand: aHand
+ colorRamp last value: aColor.
+ isTranslucent := nil.
+ pixelRamp := nil.
+ aMorph changed.!
Item was added:
+ BitBlt subclass: #GrafPort
+ instanceVariableNames: 'alpha fillPattern lastFont lastFontForegroundColor lastFontBackgroundColor'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: GrafPort>>alphaBits: (in category 'accessing') -----
+ alphaBits: a
+ alpha := a!
Item was added:
+ ----- Method: GrafPort>>clippedBy: (in category 'copying') -----
+ clippedBy: aRectangle
+ ^ self copy clipBy: aRectangle!
Item was added:
+ ----- Method: GrafPort>>contentsOfArea:into: (in category 'accessing') -----
+ contentsOfArea: aRectangle into: aForm
+ destForm
+ displayOn: aForm
+ at: aRectangle origin
+ clippingBox: (0 at 0 extent: aRectangle extent).
+ ^aForm!
Item was added:
+ ----- Method: GrafPort>>copyBits (in category 'copying') -----
+ copyBits
+ "Override copybits to do translucency if desired"
+
+ (combinationRule >= 30 and: [combinationRule <= 31])
+ ifTrue: [
+ self copyBitsTranslucent: (alpha ifNil: [255])]
+ ifFalse: [super copyBits]!
Item was added:
+ ----- Method: GrafPort>>displayScannerFor:foreground:background:ignoreColorChanges: (in category 'accessing') -----
+ displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode
+ ^ (DisplayScanner new text: para text textStyle: para textStyle
+ foreground: foreColor background: backColor fillBlt: self
+ ignoreColorChanges: shadowMode)
+ setPort: self clone
+ !
Item was added:
+ ----- Method: GrafPort>>fillOval: (in category 'drawing support') -----
+ fillOval: rect
+ | centerX centerY nextY yBias xBias outer nextOuterX |
+ rect area <= 0 ifTrue: [^ self].
+ height := 1.
+ yBias := rect height odd ifTrue: [0] ifFalse: [-1].
+ xBias := rect width odd ifTrue: [1] ifFalse: [0].
+ centerX := rect center x.
+ centerY := rect center y.
+ outer := EllipseMidpointTracer new on: rect.
+ nextY := rect height // 2.
+ [nextY > 0] whileTrue:[
+ nextOuterX := outer stepInY.
+ width := (nextOuterX bitShift: 1) + xBias.
+ destX := centerX - nextOuterX.
+ destY := centerY - nextY.
+ self copyBits.
+ destY := centerY + nextY + yBias.
+ self copyBits.
+ nextY := nextY - 1.
+ ].
+ destY := centerY.
+ height := 1 + yBias.
+ width := rect width.
+ destX := rect left.
+ self copyBits.
+ !
Item was added:
+ ----- Method: GrafPort>>fillPattern: (in category 'accessing') -----
+ fillPattern: anObject
+ fillPattern := anObject.
+ self fillColor: anObject.!
Item was added:
+ ----- Method: GrafPort>>fillRect:offset: (in category 'drawing support') -----
+ fillRect: rect offset: aPoint
+ "The offset is really just for stupid InfiniteForms."
+ | fc |
+ fillPattern class == InfiniteForm ifTrue:[
+ fc := halftoneForm.
+ self fillColor: nil.
+ fillPattern displayOnPort: ((self clippedBy: rect) colorMap: nil) at: aPoint.
+ halftoneForm := fc.
+ ^self].
+
+ destX := rect left.
+ destY := rect top.
+ sourceX := 0.
+ sourceY := 0.
+ width := rect width.
+ height := rect height.
+ self copyBits.!
Item was added:
+ ----- Method: GrafPort>>fillRoundRect:radius: (in category 'drawing support') -----
+ fillRoundRect: aRectangle radius: radius
+ | nextY outer nextOuterX ovalDiameter rectExtent rectOffset rectX rectY rectWidth rectHeight ovalRadius ovalRect |
+ aRectangle area <= 0 ifTrue: [^ self].
+ ovalDiameter := (radius * 2) asPoint min: aRectangle extent.
+ (ovalDiameter x <= 0 or:[ovalDiameter y <= 0]) ifTrue:[
+ ^self fillRect: aRectangle offset: 0 at 0.
+ ].
+ "force diameter to be even - this simplifies lots of stuff"
+ ovalRadius := (ovalDiameter x // 2) @ (ovalDiameter y // 2).
+ (ovalRadius x <= 0 or:[ovalRadius y <= 0]) ifTrue:[
+ ^self fillRect: aRectangle offset: 0 at 0.
+ ].
+ ovalDiameter := ovalRadius * 2.
+ rectExtent := aRectangle extent - ovalDiameter.
+ rectWidth := rectExtent x.
+ rectHeight := rectExtent y.
+ rectOffset := aRectangle origin + ovalRadius.
+ rectX := rectOffset x.
+ rectY := rectOffset y.
+
+ ovalRect := ovalRadius negated extent: ovalDiameter.
+
+ height := 1.
+ outer := EllipseMidpointTracer new on: ovalRect.
+ nextY := ovalRadius y.
+ "upper and lower portions of round rect"
+ [nextY > 0] whileTrue:[
+ nextOuterX := outer stepInY.
+ width := nextOuterX * 2 + rectWidth.
+ destX := rectX - nextOuterX.
+ destY := rectY - nextY.
+ self copyBits.
+ destY := rectY + nextY + rectHeight - 1.
+ self copyBits.
+ nextY := nextY - 1.
+ ].
+ destX := aRectangle left.
+ destY := rectOffset y.
+ height := rectHeight.
+ width := aRectangle width.
+ self copyBits.
+ !
Item was added:
+ ----- Method: GrafPort>>frameOval:borderWidth: (in category 'drawing support') -----
+ frameOval: rect borderWidth: borderWidth
+ | centerX centerY nextY yBias xBias wp outer inner nextOuterX nextInnerX fillAlpha |
+ rect area <= 0 ifTrue: [^ self].
+ height := 1.
+ wp := borderWidth asPoint.
+ yBias := rect height odd ifTrue: [0] ifFalse: [-1].
+ xBias := rect width odd ifTrue: [1] ifFalse: [0].
+ centerX := rect center x.
+ centerY := rect center y.
+ outer := EllipseMidpointTracer new on: rect.
+ inner := EllipseMidpointTracer new on: (rect insetBy: wp).
+ nextY := rect height // 2.
+ 1 to: (wp y min: nextY) do:[:i|
+ nextOuterX := outer stepInY.
+ width := (nextOuterX bitShift: 1) + xBias.
+ destX := centerX - nextOuterX.
+ destY := centerY - nextY.
+ self copyBits.
+ destY := centerY + nextY + yBias.
+ self copyBits.
+ nextY := nextY - 1.
+ ].
+ [nextY > 0] whileTrue:[
+ nextOuterX := outer stepInY.
+ nextInnerX := inner stepInY.
+ destX := centerX - nextOuterX.
+ destY := centerY - nextY.
+ width := nextOuterX - nextInnerX.
+ self copyBits.
+ destX := centerX + nextInnerX + xBias.
+ self copyBits.
+ destX := centerX - nextOuterX.
+ destY := centerY + nextY + yBias.
+ self copyBits.
+ destX := centerX + nextInnerX + xBias.
+ self copyBits.
+ nextY := nextY - 1.
+ ].
+ destY := centerY.
+ height := 1 + yBias.
+ width := wp x.
+ destX := rect left.
+ self copyBits.
+ destX := rect right - wp x.
+ self copyBits.
+ !
Item was added:
+ ----- Method: GrafPort>>frameRect:borderWidth: (in category 'drawing support') -----
+ frameRect: rect borderWidth: borderWidth
+ sourceX := 0.
+ sourceY := 0.
+ (rect areasOutside: (rect insetBy: borderWidth)) do:
+ [:edgeStrip | self destRect: edgeStrip; copyBits].
+ !
Item was added:
+ ----- Method: GrafPort>>frameRectBottom:height: (in category 'drawing support') -----
+ frameRectBottom: rect height: h
+
+ destX := rect left + 1.
+ destY := rect bottom - 1.
+ width := rect width - 2.
+ height := 1.
+ 1 to: h do: [:i |
+ self copyBits.
+ destX := destX + 1.
+ destY := destY - 1.
+ width := width - 2].
+ !
Item was added:
+ ----- Method: GrafPort>>frameRectRight:width: (in category 'drawing support') -----
+ frameRectRight: rect width: w
+
+ width := 1.
+ height := rect height - 1.
+ destX := rect right - 1.
+ destY := rect top + 1.
+ 1 to: w do: [:i |
+ self copyBits.
+ destX := destX - 1.
+ destY := destY + 1.
+ height := height - 2].
+ !
Item was added:
+ ----- Method: GrafPort>>frameRoundRect:radius:borderWidth: (in category 'drawing support') -----
+ frameRoundRect: aRectangle radius: radius borderWidth: borderWidth
+ | nextY outer nextOuterX ovalDiameter rectExtent rectOffset rectX rectY rectWidth rectHeight ovalRadius ovalRect innerRadius innerDiameter innerRect inner nextInnerX wp |
+ aRectangle area <= 0 ifTrue: [^ self].
+ ovalDiameter := (radius * 2) asPoint min: aRectangle extent.
+ (ovalDiameter x <= 0 or:[ovalDiameter y <= 0]) ifTrue:[
+ ^self fillRect: aRectangle offset: 0 at 0.
+ ].
+ "force diameter to be even - this simplifies lots of stuff"
+ ovalRadius := (ovalDiameter x // 2) @ (ovalDiameter y // 2).
+ (ovalRadius x <= 0 or:[ovalRadius y <= 0]) ifTrue:[
+ ^self fillRect: aRectangle offset: 0 at 0.
+ ].
+ wp := borderWidth asPoint.
+ ovalDiameter := ovalRadius * 2.
+ innerRadius := ovalRadius - borderWidth max: 0 at 0.
+ innerDiameter := innerRadius * 2.
+
+ rectExtent := aRectangle extent - ovalDiameter.
+ rectWidth := rectExtent x.
+ rectHeight := rectExtent y.
+
+ rectOffset := aRectangle origin + ovalRadius.
+ rectX := rectOffset x.
+ rectY := rectOffset y.
+
+ ovalRect := 0 at 0 extent: ovalDiameter.
+ innerRect := 0 at 0 extent: innerDiameter.
+
+ height := 1.
+ outer := EllipseMidpointTracer new on: ovalRect.
+ inner := EllipseMidpointTracer new on: innerRect.
+
+ nextY := ovalRadius y.
+
+ 1 to: (wp y min: nextY) do:[:i|
+ nextOuterX := outer stepInY.
+ width := nextOuterX * 2 + rectWidth.
+ destX := rectX - nextOuterX.
+ destY := rectY - nextY.
+ self copyBits.
+ destY := rectY + nextY + rectHeight - 1.
+ self copyBits.
+ nextY := nextY - 1.
+ ].
+ [nextY > 0] whileTrue:[
+ nextOuterX := outer stepInY.
+ nextInnerX := inner stepInY.
+ destX := rectX - nextOuterX.
+ destY := rectY - nextY.
+ width := nextOuterX - nextInnerX.
+ self copyBits.
+ destX := rectX + nextInnerX + rectWidth.
+ self copyBits.
+ destX := rectX - nextOuterX.
+ destY := rectY + nextY + rectHeight-1.
+ self copyBits.
+ destX := rectX + nextInnerX + rectWidth.
+ self copyBits.
+ nextY := nextY - 1.
+ ].
+
+ destX := aRectangle left.
+ destY := rectOffset y.
+ height := rectHeight.
+ width := wp x.
+ self copyBits.
+ destX := aRectangle right - width.
+ self copyBits.
+ innerRadius y = 0 ifTrue:[
+ destX := aRectangle left + wp x.
+ destY := rectY.
+ width := rectWidth.
+ height := wp y - ovalRadius y.
+ self copyBits.
+ destY := aRectangle bottom - wp y.
+ self copyBits.
+ ].!
Item was added:
+ ----- Method: GrafPort>>image:at:sourceRect:rule: (in category 'drawing support') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule
+ "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."
+
+ sourceForm := aForm.
+ combinationRule := rule.
+ self sourceRect: sourceRect.
+ self destOrigin: aPoint.
+ self copyBits!
Item was added:
+ ----- Method: GrafPort>>image:at:sourceRect:rule:alpha: (in category 'drawing support') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha
+ "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."
+
+ sourceForm := aForm.
+ combinationRule := rule.
+ self sourceRect: sourceRect.
+ self destOrigin: aPoint.
+ self copyBitsTranslucent: (alpha := (sourceAlpha * 255) truncated min: 255 max: 0).!
Item was added:
+ ----- Method: GrafPort>>installStrikeFont: (in category 'private') -----
+ installStrikeFont: aStrikeFont
+
+ ^ self installStrikeFont: aStrikeFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]).
+ !
Item was added:
+ ----- Method: GrafPort>>installStrikeFont:foregroundColor:backgroundColor: (in category 'private') -----
+ installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor
+ super installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor.
+ aStrikeFont glyphs depth = 1 ifTrue: [
+ alpha := foregroundColor privateAlpha.
+ "dynamically switch between blend modes to support translucent text"
+ "To handle the transition from TTCFont to StrikeFont, rule 34 must be taken into account."
+ alpha = 255 ifTrue:[
+ combinationRule = 30 ifTrue: [combinationRule := Form over].
+ combinationRule = 31 ifTrue: [combinationRule := Form paint].
+ combinationRule = 34 ifTrue: [combinationRule := Form paint].
+ combinationRule = 41 ifTrue: [combinationRule := Form paint]. "41 is SPRmode"
+ ] ifFalse:[
+ combinationRule = Form over ifTrue: [combinationRule := 30].
+ combinationRule = Form paint ifTrue: [combinationRule := 31].
+ combinationRule = 34 ifTrue: [combinationRule := 31].
+ combinationRule = 41 ifTrue: [combinationRule := 31]. "41 is SPR mode"
+ ]
+ ].
+ lastFont := aStrikeFont.
+ lastFontForegroundColor := foregroundColor.
+ lastFontBackgroundColor := backgroundColor.
+ !
Item was added:
+ ----- Method: GrafPort>>installTTCFont: (in category 'private') -----
+ installTTCFont: aTTCFont
+
+ ^ self installTTCFont: aTTCFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]).
+ !
Item was added:
+ ----- Method: GrafPort>>installTTCFont:foregroundColor:backgroundColor: (in category 'private') -----
+ installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor
+
+ super installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor.
+ lastFont := aTTCFont.
+ lastFontForegroundColor := foregroundColor.
+ lastFontBackgroundColor := backgroundColor.
+ !
Item was added:
+ ----- Method: GrafPort>>lastFont (in category 'private') -----
+ lastFont
+
+ ^ lastFont.
+ !
Item was added:
+ ----- Method: GrafPort>>lastFontForegroundColor (in category 'accessing') -----
+ lastFontForegroundColor
+ ^lastFontForegroundColor!
Item was added:
+ ----- Method: GrafPort>>stencil:at:sourceRect: (in category 'drawing support') -----
+ stencil: stencilForm at: aPoint sourceRect: aRect
+ "Paint using aColor wherever stencilForm has non-zero pixels"
+ self sourceForm: stencilForm;
+ destOrigin: aPoint;
+ sourceRect: aRect.
+ self copyBits!
Item was added:
+ BracketSliderMorph subclass: #HColorSelectorMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !HColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:58' prior: 0!
+ ColorComponentSelector showing a hue rainbow palette.!
Item was added:
+ ----- Method: HColorSelectorMorph>>color: (in category 'as yet unclassified') -----
+ color: aColor
+ "Ignore to preserve fill style."
+ !
Item was added:
+ ----- Method: HColorSelectorMorph>>defaultFillStyle (in category 'as yet unclassified') -----
+ defaultFillStyle
+ "Answer the hue gradient."
+
+ ^(GradientFillStyle colors: ((0.0 to: 359.9 by: 0.1) collect: [:a | Color h: a s: 1.0 v: 1.0]))
+ origin: self topLeft;
+ direction: (self bounds isWide
+ ifTrue: [self width at 0]
+ ifFalse: [0 at self height])!
Item was added:
+ Morph subclass: #HSVAColorSelectorMorph
+ instanceVariableNames: 'hsvMorph aMorph'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !HSVAColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55' prior: 0!
+ Colour selector featuring a saturation/volume area, hue selection strip and alpha selection strip.!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>aMorph (in category 'accessing') -----
+ aMorph
+ "The alpha-selector morph."
+ ^ aMorph!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>aMorph: (in category 'accessing') -----
+ aMorph: anAColorSelectorMorph
+ "The alpha-selector morph."
+ aMorph := anAColorSelectorMorph!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>alphaSelected: (in category 'as yet unclassified') -----
+ alphaSelected: aFloat
+ "The alpha has changed."
+
+ self triggerSelectedColor!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>colorSelected: (in category 'as yet unclassified') -----
+ colorSelected: aColor
+ "A color has been selected. Set the base color for the alpha channel."
+
+ self aMorph color: aColor.
+ self triggerSelectedColor!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>defaultColor (in category 'as yet unclassified') -----
+ defaultColor
+ "Answer the default color/fill style for the receiver."
+
+ ^Color transparent
+ !
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>hsvMorph (in category 'accessing') -----
+ hsvMorph
+ "Answer the value of hsvMorph"
+
+ ^ hsvMorph!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>hsvMorph: (in category 'accessing') -----
+ hsvMorph: anObject
+ "Set the value of hsvMorph"
+
+ hsvMorph := anObject!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>initialize (in category 'as yet unclassified') -----
+ initialize
+ "Initialize the receiver."
+
+ super initialize.
+ self
+ extent: 180 at 168;
+ changeTableLayout;
+ cellInset: 4;
+ aMorph: self newAColorMorph;
+ hsvMorph: self newHSVColorMorph;
+ addMorphBack: self hsvMorph;
+ addMorphBack: self aMorph.
+ self aMorph color: self hsvMorph selectedColor!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>newAColorMorph (in category 'as yet unclassified') -----
+ newAColorMorph
+ "Answer a new alpha color morph."
+
+ ^AColorSelectorMorph new
+ model: self;
+ hResizing: #spaceFill;
+ vResizing: #rigid;
+ setValueSelector: #alphaSelected:;
+ extent: 24 at 24!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>newHSVColorMorph (in category 'as yet unclassified') -----
+ newHSVColorMorph
+ "Answer a new hue/saturation/volume color morph."
+
+ ^HSVColorSelectorMorph new
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ when: #colorSelected send: #colorSelected: to: self!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>selectedColor (in category 'as yet unclassified') -----
+ selectedColor
+ "Answer the selected color."
+
+ ^self hsvMorph selectedColor alpha: self aMorph value!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>selectedColor: (in category 'as yet unclassified') -----
+ selectedColor: aColor
+ "Set the hue and sv components."
+
+ self aMorph value: aColor alpha.
+ self hsvMorph selectedColor: aColor asNontranslucentColor!
Item was added:
+ ----- Method: HSVAColorSelectorMorph>>triggerSelectedColor (in category 'as yet unclassified') -----
+ triggerSelectedColor
+ "Trigger the event for the selected colour"
+ self
+ triggerEvent: #selectedColor
+ with: self selectedColor.
+ self changed: #selectedColor!
Item was added:
+ Morph subclass: #HSVColorSelectorMorph
+ instanceVariableNames: 'svMorph hMorph'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !HSVColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55' prior: 0!
+ Colour selector featuring a saturation/volume area and a hue selection strip.!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>colorSelected: (in category 'as yet unclassified') -----
+ colorSelected: aColor
+ "A color has been selected. Make the hue match."
+
+ "self hMorph value: aColor hue / 360.
+ self svMorph basicColor: (Color h: aColor hue s: 1.0 v: 1.0)."
+ self triggerEvent: #colorSelected with: aColor!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>defaultColor (in category 'as yet unclassified') -----
+ defaultColor
+ "Answer the default color/fill style for the receiver."
+
+ ^Color transparent
+ !
Item was added:
+ ----- Method: HSVColorSelectorMorph>>hMorph (in category 'accessing') -----
+ hMorph
+ "Answer the value of hMorph"
+
+ ^ hMorph!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>hMorph: (in category 'accessing') -----
+ hMorph: anObject
+ "Set the value of hMorph"
+
+ hMorph := anObject!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>hue: (in category 'as yet unclassified') -----
+ hue: aFloat
+ "Set the hue in the range 0.0 - 1.0. Update the SV morph and hMorph."
+
+ self hMorph value: aFloat.
+ self svMorph color: (Color h: aFloat * 359.9 s: 1.0 v: 1.0)!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>initialize (in category 'as yet unclassified') -----
+ initialize
+ "Initialize the receiver."
+
+ super initialize.
+ self
+ borderWidth: 0;
+ changeTableLayout;
+ cellInset: 4;
+ listDirection: #leftToRight;
+ cellPositioning: #topLeft;
+ svMorph: self newSVColorMorph;
+ hMorph: self newHColorMorph;
+ addMorphBack: self svMorph;
+ addMorphBack: self hMorph;
+ extent: 192 at 152;
+ hue: 0.5!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>newHColorMorph (in category 'as yet unclassified') -----
+ newHColorMorph
+ "Answer a new hue color morph."
+
+ ^HColorSelectorMorph new
+ model: self;
+ setValueSelector: #hue:;
+ hResizing: #rigid;
+ vResizing: #spaceFill;
+ extent: 36 at 36!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>newSVColorMorph (in category 'as yet unclassified') -----
+ newSVColorMorph
+ "Answer a new saturation/volume color morph."
+
+ ^SVColorSelectorMorph new
+ extent: 152 at 152;
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ when: #colorSelected send: #colorSelected: to: self!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>selectedColor (in category 'as yet unclassified') -----
+ selectedColor
+ "Answer the selected color."
+
+ ^self svMorph selectedColor!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>selectedColor: (in category 'as yet unclassified') -----
+ selectedColor: aColor
+ "Set the hue and sv components."
+
+ self hue: aColor hue / 360.
+ self svMorph selectedColor: aColor!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>svMorph (in category 'accessing') -----
+ svMorph
+ "Answer the value of svMorph"
+
+ ^ svMorph!
Item was added:
+ ----- Method: HSVColorSelectorMorph>>svMorph: (in category 'accessing') -----
+ svMorph: anObject
+ "Set the value of svMorph"
+
+ svMorph := anObject!
Item was added:
+ Morph subclass: #HaloMorph
+ instanceVariableNames: 'target innerTarget positionOffset angleOffset minExtent growingOrRotating directionArrowAnchor haloBox simpleMode originalExtent'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !HaloMorph commentStamp: '<historical>' prior: 0!
+ This morph provides a halo of handles for its target morph. Dragging, duplicating, rotating, and resizing to be done by mousing down on the appropriate handle. There are also handles for help and for a menu of infrequently used operations.!
Item was added:
+ ----- Method: HaloMorph>>acceptNameEdit (in category 'initialization') -----
+ acceptNameEdit
+ "If the name is currently under edit, accept the changes"
+
+ | label |
+ (label := self findA: NameStringInHalo) ifNotNil:
+ [label hasFocus ifTrue:
+ [label lostFocusWithoutAccepting]]!
Item was added:
+ ----- Method: HaloMorph>>addChooseGraphicHandle: (in category 'handles') -----
+ addChooseGraphicHandle: haloSpec
+ "If the target is a sketch morph, and if the governing preference is set, add a halo handle allowing the user to select a new graphic"
+
+ (Preferences showChooseGraphicHaloHandle and: [innerTarget isSketchMorph]) ifTrue:
+ [self addHandle: haloSpec
+ on: #mouseDown send: #chooseNewGraphicFromHalo to: innerTarget]
+ !
Item was added:
+ ----- Method: HaloMorph>>addCircleHandles (in category 'private') -----
+ addCircleHandles
+ | box |
+ simpleMode := false.
+ target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos].
+
+ self removeAllMorphs. "remove old handles, if any"
+ self bounds: target renderedMorph worldBoundsForHalo. "update my size"
+ box := self basicBox.
+
+ target addHandlesTo: self box: box.
+
+ self addName.
+ growingOrRotating := false.
+ self layoutChanged.
+ self changed.
+ !
Item was added:
+ ----- Method: HaloMorph>>addCollapseHandle: (in category 'handles') -----
+ addCollapseHandle: handleSpec
+ "Add the collapse handle, with all of its event handlers set up, unless the target's owner is not the world or the hand."
+
+ | collapseHandle |
+ (target owner notNil "nil happens, amazingly"
+ and: [target owner isWorldOrHandMorph])
+ ifFalse: [^ self].
+ collapseHandle := self addHandle: handleSpec
+ on: #mouseDown send: #mouseDownInCollapseHandle:with: to: self.
+ collapseHandle on: #mouseUp send: #maybeCollapse:with: to: self.
+ collapseHandle on: #mouseMove send: #setDismissColor:with: to: self
+ !
Item was added:
+ ----- Method: HaloMorph>>addDebugHandle: (in category 'handles') -----
+ addDebugHandle: handleSpec
+ Preferences debugHaloHandle ifTrue:
+ [self addHandle: handleSpec
+ on: #mouseDown send: #doDebug:with: to: self]
+ !
Item was added:
+ ----- Method: HaloMorph>>addDirectionHandles (in category 'private') -----
+ addDirectionHandles
+
+ | centerHandle d w directionShaft patch patchColor crossHairColor |
+ self showingDirectionHandles ifFalse: [^ self].
+
+ directionArrowAnchor := (target point: target referencePosition in: self world) rounded.
+ patch := target imageFormForRectangle: (Rectangle center: directionArrowAnchor extent: 3 at 3).
+ patchColor := patch colorAt: 1 at 1.
+
+ (directionShaft := LineMorph newSticky makeForwardArrow)
+ borderWidth: 2; borderColor: (Color green orColorUnlike: patchColor).
+ self positionDirectionShaft: directionShaft.
+ self addMorphFront: directionShaft.
+ directionShaft setCenteredBalloonText: 'Set forward direction' translated;
+ on: #mouseDown send: #doDirection:with: to: self;
+ on: #mouseMove send: #trackDirectionArrow:with: to: self;
+ on: #mouseUp send: #setDirection:with: to: self.
+
+ d := 15. "diameter" w := 3. "borderWidth"
+ crossHairColor := Color red orColorUnlike: patchColor.
+ (centerHandle := EllipseMorph newBounds: (0 at 0 extent: d at d) color: Color transparent)
+ borderWidth: w; borderColor: (Color blue orColorUnlike: patchColor);
+ addMorph: (LineMorph from: (d//2)@w to: (d//2)@(d-w-1) color: crossHairColor width: 1) lock;
+ addMorph: (LineMorph from: w@(d//2) to: (d-w-1)@(d//2) color: crossHairColor width: 1) lock;
+ align: centerHandle bounds center with: directionArrowAnchor.
+ centerHandle wantsYellowButtonMenu: false.
+ self addMorph: centerHandle.
+ centerHandle setCenteredBalloonText: 'Rotation center (hold down the shift key and drag from here to change it)' translated;
+ on: #mouseDown send: #prepareToTrackCenterOfRotation:with: to: self;
+ on: #mouseMove send: #trackCenterOfRotation:with: to: self;
+ on: #mouseUp send: #setCenterOfRotation:with: to: self
+ !
Item was added:
+ ----- Method: HaloMorph>>addDismissHandle: (in category 'handles') -----
+ addDismissHandle: handleSpec
+ "Add the dismiss handle according to the spec, unless selectiveHalos is on and my target resists dismissal"
+
+ | dismissHandle |
+ (target okayToAddDismissHandle or: [Preferences selectiveHalos not]) ifTrue:
+ [dismissHandle := self addHandle: handleSpec
+ on: #mouseDown send: #mouseDownInDimissHandle:with: to: self.
+ dismissHandle on: #mouseUp send: #maybeDismiss:with: to: self.
+ dismissHandle on: #mouseDown send: #setDismissColor:with: to: self.
+ dismissHandle on: #mouseMove send: #setDismissColor:with: to: self]
+ !
Item was added:
+ ----- Method: HaloMorph>>addDragHandle: (in category 'handles') -----
+ addDragHandle: haloSpec
+ (self addHandle: haloSpec on: #mouseDown send: #startDrag:with: to: self)
+ on: #mouseMove send: #doDrag:with: to: self
+
+
+ !
Item was added:
+ ----- Method: HaloMorph>>addDupHandle: (in category 'handles') -----
+ addDupHandle: haloSpec
+ "Add the halo that offers duplication, or, when shift is down, make-sibling"
+
+ self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self
+
+ !
Item was added:
+ ----- Method: HaloMorph>>addFewerHandlesHandle: (in category 'handles') -----
+ addFewerHandlesHandle: haloSpec
+ self addHandle: haloSpec on: #mouseDown send: #addSimpleHandles to: self
+ !
Item was added:
+ ----- Method: HaloMorph>>addFontEmphHandle: (in category 'handles') -----
+ addFontEmphHandle: haloSpec
+ (innerTarget isTextMorph)
+ ifTrue:
+ [self
+ addHandle: haloSpec
+ on: #mouseDown
+ send: #chooseEmphasisOrAlignment
+ to: innerTarget]!
Item was added:
+ ----- Method: HaloMorph>>addFontSizeHandle: (in category 'handles') -----
+ addFontSizeHandle: haloSpec
+ (innerTarget isTextMorph)
+ ifTrue:
+ [self
+ addHandle: haloSpec
+ on: #mouseDown
+ send: #chooseFont
+ to: innerTarget]!
Item was added:
+ ----- Method: HaloMorph>>addFontStyleHandle: (in category 'handles') -----
+ addFontStyleHandle: haloSpec
+ (innerTarget isTextMorph)
+ ifTrue:
+ [self
+ addHandle: haloSpec
+ on: #mouseDown
+ send: #chooseStyle
+ to: innerTarget]!
Item was added:
+ ----- Method: HaloMorph>>addFullHandles (in category 'private') -----
+ addFullHandles
+ "Later, obey a preference to choose between circle-iconic and solid-circles"
+ self addCircleHandles!
Item was added:
+ ----- Method: HaloMorph>>addGrabHandle: (in category 'handles') -----
+ addGrabHandle: haloSpec
+ "If appropriate, add the black halo handle for picking up the target"
+
+ innerTarget okayToAddGrabHandle ifTrue:
+ [self addHandle: haloSpec on: #mouseDown send: #doGrab:with: to: self]
+
+ !
Item was added:
+ ----- Method: HaloMorph>>addGraphicalHandle:at:on:send:to: (in category 'private') -----
+ addGraphicalHandle: formKey at: aPoint on: eventName send: selector to: recipient
+ "Add the supplied form as a graphical handle centered at the given point, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle."
+ | handle |
+ handle := self addGraphicalHandleFrom: formKey at: aPoint.
+ handle on: eventName send: selector to: recipient.
+ handle setBalloonText: (target balloonHelpTextForHandle: handle) translated.
+ ^ handle
+ !
Item was added:
+ ----- Method: HaloMorph>>addGraphicalHandleFrom:at: (in category 'private') -----
+ addGraphicalHandleFrom: formKey at: aPoint
+ "Add the supplied form as a graphical handle centered at the given point. Return the handle."
+ | handle aForm |
+ aForm := (ScriptingSystem formAtKey: formKey) ifNil: [ScriptingSystem formAtKey: #SolidMenu].
+ handle := ImageMorph new image: aForm; bounds: (Rectangle center: aPoint extent: aForm extent).
+ handle wantsYellowButtonMenu: false.
+ self addMorph: handle.
+ handle on: #mouseUp send: #endInteraction to: self.
+ ^ handle
+ !
Item was added:
+ ----- Method: HaloMorph>>addGrowHandle: (in category 'handles') -----
+ addGrowHandle: haloSpec
+ target isFlexMorph ifFalse:
+ [(self addHandle: haloSpec
+ on: #mouseDown send: #startGrow:with: to: self)
+ on: #mouseMove send: #doGrow:with: to: self]
+ "This or addScaleHandle:, but not both, will prevail at any one time"
+ !
Item was added:
+ ----- Method: HaloMorph>>addHandle:on:send:to: (in category 'private') -----
+ addHandle: handleSpec on: eventName send: selector to: recipient
+ "Add a handle within the halo box as per the haloSpec, and set
+ it up to respond to the given event by sending the given
+ selector to the given recipient. Return the handle."
+ | handle aPoint |
+
+ aPoint := self
+ positionIn: haloBox
+ horizontalPlacement: handleSpec horizontalPlacement
+ verticalPlacement: handleSpec verticalPlacement.
+
+ handle := self
+ addHandleAt: aPoint
+ color: (Color colorFrom: handleSpec color)
+ icon: handleSpec iconSymbol
+ on: eventName
+ send: selector
+ to: recipient.
+
+ self isMagicHalo
+ ifTrue: [
+ handle on: #mouseEnter send: #handleEntered to: self.
+ handle on: #mouseLeave send: #handleLeft to: self].
+
+ ^ handle!
Item was added:
+ ----- Method: HaloMorph>>addHandleAt:color:icon:on:send:to: (in category 'private') -----
+ addHandleAt: aPoint color: aColor icon: iconName on: eventName send: selector to: recipient
+ "Add a handle centered at the given point with the given color,
+ and set it up to respond to the given event by sending the
+ given selector to the given recipient. Return the handle."
+ | handle |
+ handle := self createHandleAt: aPoint color: (aColor alpha: 0.8) iconName: iconName.
+ self addMorph: handle.
+
+ handle on: #mouseUp send: #endInteraction to: self.
+ handle on: eventName send: selector to: recipient.
+ handle setBalloonText: (target balloonHelpTextForHandle: handle) translated.
+
+ ^ handle !
Item was added:
+ ----- Method: HaloMorph>>addHandleAt:color:on:send:to: (in category 'private') -----
+ addHandleAt: aPoint color: aColor on: eventName send: selector to: recipient
+ ^ self addHandleAt: aPoint color: aColor icon: nil on: eventName send: selector to: recipient
+ !
Item was added:
+ ----- Method: HaloMorph>>addHandles (in category 'private') -----
+ addHandles
+ simpleMode == true
+ ifTrue:
+ [self addSimpleHandles]
+ ifFalse:
+ [self addCircleHandles]
+ !
Item was added:
+ ----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') -----
+ addHandlesForWorldHalos
+ "Add handles for world halos, like the man said"
+
+ | box w |
+ w := self world ifNil:[target world].
+ self removeAllMorphs. "remove old handles, if any"
+ self bounds: target bounds.
+ box := w bounds insetBy: 9.
+ target addWorldHandlesTo: self box: box.
+
+ Preferences uniqueNamesInHalos ifTrue:
+ [innerTarget assureExternalName].
+ self addNameBeneath: (box insetBy: (0 at 0 corner: 0 at 10)) string: innerTarget externalName.
+ growingOrRotating := false.
+ self layoutChanged.
+ self changed.
+ !
Item was added:
+ ----- Method: HaloMorph>>addHelpHandle: (in category 'handles') -----
+ addHelpHandle: haloSpec
+ target balloonText ifNotNil:
+ [(self addHandle: haloSpec on: #mouseDown send: #mouseDownOnHelpHandle: to: innerTarget)
+ on: #mouseUp send: #deleteBalloon to: innerTarget]
+ !
Item was added:
+ ----- Method: HaloMorph>>addMakeSiblingHandle: (in category 'handles') -----
+ addMakeSiblingHandle: haloSpec
+ "Add the halo handle that allows a sibling instance to be torn off, or, if the shift key is down, for a deep-copy duplicate to be made."
+
+ self addHandle: haloSpec on: #mouseDown send: #doMakeSiblingOrDup:with: to: self
+
+ !
Item was added:
+ ----- Method: HaloMorph>>addMenuHandle: (in category 'handles') -----
+ addMenuHandle: haloSpec
+ self addHandle: haloSpec on: #mouseDown send: #doMenu:with: to: self!
Item was added:
+ ----- Method: HaloMorph>>addName (in category 'private') -----
+ addName
+ "Add a name readout at the bottom of the halo."
+
+ Preferences uniqueNamesInHalos ifTrue:
+ [target assureExternalName].
+
+ self addNameBeneath: self basicBox string: target externalName
+ !
Item was added:
+ ----- Method: HaloMorph>>addNameBeneath:string: (in category 'private') -----
+ addNameBeneath: outerRectangle string: aString
+ "Add a name display centered beneath the bottom of the outer rectangle. Return the handle."
+
+ | nameMorph namePosition w |
+ w := self world ifNil:[target world].
+ nameMorph := NameStringInHalo contents: aString font: Preferences standardHaloLabelFont.
+ nameMorph wantsYellowButtonMenu: false.
+ nameMorph color: Color black.
+ nameMorph useStringFormat; target: innerTarget; putSelector: #tryToRenameTo:.
+ namePosition := outerRectangle bottomCenter -
+ ((nameMorph width // 2) @ (self handleSize negated // 2 - 1)).
+ nameMorph position: (namePosition min: w viewBox bottomRight - nameMorph extent y + 2).
+ nameMorph balloonTextSelector: #objectNameInHalo.
+ self addMorph: nameMorph.
+ ^ nameMorph!
Item was added:
+ ----- Method: HaloMorph>>addPaintBgdHandle: (in category 'handles') -----
+ addPaintBgdHandle: haloSpec
+ (innerTarget isKindOf: PasteUpMorph) ifTrue:
+ [self addHandle: haloSpec
+ on: #mouseDown send: #paintBackground to: innerTarget].
+ !
Item was added:
+ ----- Method: HaloMorph>>addPoohHandle: (in category 'handles') -----
+ addPoohHandle: handleSpec
+ (innerTarget isKindOf: (Smalltalk at: #WonderlandCameraMorph ifAbsent:[nil])) ifTrue:
+ [self addHandle: handleSpec on: #mouseDown send: #strokeMode to: innerTarget]
+ !
Item was added:
+ ----- Method: HaloMorph>>addRecolorHandle: (in category 'handles') -----
+ addRecolorHandle: haloSpec
+ "Add a recolor handle to the receiver, if appropriate"
+
+ | recolorHandle |
+
+ "since this halo now opens a more general properties panel, allow it in all cases"
+ "innerTarget canSetColor ifTrue:"
+
+ recolorHandle := self addHandle: haloSpec on: #mouseUp send: #doRecolor:with: to: self.
+ recolorHandle on: #mouseUp send: #doRecolor:with: to: self
+
+ !
Item was added:
+ ----- Method: HaloMorph>>addRepaintHandle: (in category 'handles') -----
+ addRepaintHandle: haloSpec
+ (innerTarget isSketchMorph) ifTrue:
+ [self addHandle: haloSpec
+ on: #mouseDown send: #editDrawing to: innerTarget]
+ !
Item was added:
+ ----- Method: HaloMorph>>addRotateHandle: (in category 'handles') -----
+ addRotateHandle: haloSpec
+ (self addHandle: haloSpec on: #mouseDown send: #startRot:with: to: self)
+ on: #mouseMove send: #doRot:with: to: self
+
+ !
Item was added:
+ ----- Method: HaloMorph>>addScaleHandle: (in category 'handles') -----
+ addScaleHandle: haloSpec
+ target isFlexMorph ifTrue:
+ [(self addHandle: haloSpec
+ on: #mouseDown send: #startScale:with: to: self)
+ on: #mouseMove send: #doScale:with: to: self].
+ "This or addGrowHandle:, but not both, will prevail at any one time"
+ !
Item was added:
+ ----- Method: HaloMorph>>addScriptHandle: (in category 'handles') -----
+ addScriptHandle: haloSpec
+ "If the halo's innerTarget claims it wants a Script handle, add one to the receiver, forming it as per haloSpec"
+
+ innerTarget wantsScriptorHaloHandle ifTrue:
+ [self addHandle: haloSpec
+ on: #mouseUp send: #editButtonsScript to: innerTarget]
+ !
Item was added:
+ ----- Method: HaloMorph>>addSimpleHandles (in category 'private') -----
+ addSimpleHandles
+ target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos].
+ self removeAllMorphs. "remove old handles, if any"
+ self bounds: target renderedMorph worldBoundsForHalo. "update my size"
+ self innerTarget addSimpleHandlesTo: self box: self basicBoxForSimpleHalos
+
+ !
Item was added:
+ ----- Method: HaloMorph>>addSimpleHandlesForWorldHalos (in category 'private') -----
+ addSimpleHandlesForWorldHalos
+ "Nothing special at present here -- just use the regular handles. Cannot rotate or resize world"
+
+ self addHandlesForWorldHalos
+ !
Item was added:
+ ----- Method: HaloMorph>>addSimpleHandlesTo:box: (in category 'halos and balloon help') -----
+ addSimpleHandlesTo: aHaloMorph box: aBox
+ | aHandle |
+ simpleMode := true.
+
+ target isWorldMorph ifTrue: [^ self addSimpleHandlesForWorldHalos].
+
+ self removeAllMorphs. "remove old handles, if any"
+
+ self bounds: target renderedMorph worldBoundsForHalo. "update my size"
+
+ self addHandleAt: (((aBox topLeft + aBox leftCenter) // 2) + self simpleFudgeOffset) color: Color paleBuff icon: 'Halo-MoreHandles'
+ on: #mouseDown send: #addFullHandles to: self.
+
+ aHandle := self addGraphicalHandle: #Rotate at: aBox bottomLeft on: #mouseDown send: #startRot:with: to: self.
+ aHandle on: #mouseMove send: #doRot:with: to: self.
+
+ target isFlexMorph
+ ifTrue: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startScale:with: to: self)
+ on: #mouseMove send: #doScale:with: to: self]
+ ifFalse: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startGrow:with: to: self)
+ on: #mouseMove send: #doGrow:with: to: self].
+
+ innerTarget wantsSimpleSketchMorphHandles ifTrue:
+ [self addSimpleSketchMorphHandlesInBox: aBox].
+
+ growingOrRotating := false.
+ self layoutChanged.
+ self changed.
+ !
Item was added:
+ ----- Method: HaloMorph>>addSimpleSketchMorphHandlesInBox: (in category 'private') -----
+ addSimpleSketchMorphHandlesInBox: box
+
+ self addGraphicalHandle: #PaintTab at: box bottomCenter on: #mouseDown send: #editDrawing to: self innerTarget.
+
+ self addDirectionHandles!
Item was added:
+ ----- Method: HaloMorph>>addTileHandle: (in category 'handles') -----
+ addTileHandle: haloSpec
+ "Add the 'tear-off-tile' handle from the spec"
+
+ self addHandle: haloSpec on: #mouseDown send: #tearOffTileForTarget:with: to: self
+ !
Item was added:
+ ----- Method: HaloMorph>>addViewHandle: (in category 'handles') -----
+ addViewHandle: haloSpec
+ "Add the 'open viewer' handle from the halo spec"
+
+ self addHandle: haloSpec
+ on: #mouseDown send: #openViewerForTarget:with: to: self
+
+
+ !
Item was added:
+ ----- Method: HaloMorph>>addViewingHandle: (in category 'handles') -----
+ addViewingHandle: haloSpec
+ "If appropriate, add a special Viewing halo handle to the receiver"
+
+ (innerTarget isKindOf: PasteUpMorph) ifTrue:
+ [self addHandle: haloSpec
+ on: #mouseDown send: #presentViewMenu to: innerTarget].
+ !
Item was added:
+ ----- Method: HaloMorph>>basicBox (in category 'private') -----
+ basicBox
+ | aBox minSide anExtent w |
+ minSide := 4 * self handleSize.
+ anExtent := ((self width + self handleSize + 8) max: minSide) @
+ ((self height + self handleSize + 8) max: minSide).
+ aBox := Rectangle center: self center extent: anExtent.
+ w := self world ifNil:[target outermostWorldMorph].
+ ^ w
+ ifNil:
+ [aBox]
+ ifNotNil:
+ [aBox intersect: (w viewBox insetBy: 8 at 8)]
+ !
Item was added:
+ ----- Method: HaloMorph>>basicBoxForSimpleHalos (in category 'private') -----
+ basicBoxForSimpleHalos
+ | w |
+ w := self world ifNil:[target outermostWorldMorph].
+ ^ (target topRendererOrSelf worldBoundsForHalo expandBy: self handleAllowanceForIconicHalos)
+ intersect: (w bounds insetBy: 8 at 8)
+ !
Item was added:
+ ----- Method: HaloMorph>>blueButtonDown: (in category 'meta-actions') -----
+ blueButtonDown: event
+ "Transfer the halo to the next likely recipient"
+ target ifNil:[^self delete].
+ event hand obtainHalo: self.
+ positionOffset := event position - (target point: target position in: owner).
+ self isMagicHalo ifTrue:[
+ self isMagicHalo: false.
+ ^self magicAlpha: 1.0].
+ "wait for drags or transfer"
+ event hand
+ waitForClicksOrDrag: self
+ event: event
+ selectors: { #transferHalo:. nil. nil. #dragTarget:. }
+ threshold: HandMorph dragThreshold!
Item was added:
+ ----- Method: HaloMorph>>changed (in category 'updating') -----
+ changed
+ "Quicker to invalidate handles individually if target is large (especially the world)"
+
+ self extent > (200 at 200)
+ ifTrue: [(target notNil and: [target ~~ self world]) ifTrue:
+ ["Invalidate 4 outer strips first, thus subsuming separate damage."
+ (self fullBounds areasOutside: target bounds) do:
+ [:r | self invalidRect: r]].
+ self submorphsDo: [:m | m changed]]
+ ifFalse: [super changed].
+ !
Item was added:
+ ----- Method: HaloMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+ "This method is overridden so that, once up, the handles will stay up as long as the mouse is within the box that encloses all the handles even if it is not over any handle or over its owner."
+
+ ^target
+ ifNil: [super containsPoint: aPoint]
+ ifNotNil: [false]!
Item was added:
+ ----- Method: HaloMorph>>containsPoint:event: (in category 'events-processing') -----
+ containsPoint: aPoint event: anEvent
+ "Blue buttons are handled by the halo"
+ (anEvent isMouse and:[anEvent isMouseDown and:[anEvent blueButtonPressed]])
+ ifFalse:[^super containsPoint: aPoint event: anEvent].
+ ^bounds containsPoint: anEvent position!
Item was added:
+ ----- Method: HaloMorph>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ simpleMode ifNil: [simpleMode := false].
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: HaloMorph>>createHandleAt:color:iconName: (in category 'private') -----
+ createHandleAt: aPoint color: aColor iconName: iconName
+ | bou handle |
+ bou := Rectangle center: aPoint extent: self handleSize asPoint.
+ Preferences alternateHandlesLook
+ ifTrue: [handle := RectangleMorph newBounds: bou color: aColor.
+ handle useRoundedCorners.
+ self setColor: aColor toHandle: handle]
+ ifFalse: [handle := EllipseMorph newBounds: bou color: aColor].
+ handle borderWidth: 0;
+ wantsYellowButtonMenu: false.
+ ""
+ iconName isNil
+ ifFalse: [| form |
+ form := ScriptingSystem formAtKey: iconName.
+ form isNil
+ ifFalse: [| image |
+ image := ImageMorph new.
+ image image: form.
+ image color: aColor makeForegroundColor.
+ image lock.
+ handle addMorphCentered: image]].
+ ""
+ ^ handle!
Item was added:
+ ----- Method: HaloMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color
+ r: 0.6
+ g: 0.8
+ b: 1.0!
Item was added:
+ ----- Method: HaloMorph>>delete (in category 'submorphs-add/remove') -----
+ delete
+ "Delete the halo. Tell the target that it no longer has the halo; accept any pending edits to the name; and then either actually delete myself or start to fade out"
+
+ target ifNotNil:
+ [target hasHalo: false].
+ self acceptNameEdit.
+ self isMagicHalo: false.
+ Preferences haloTransitions
+ ifTrue:
+ [self stopStepping; startStepping.
+ self startSteppingSelector: #fadeOutFinally]
+ ifFalse:
+ [super delete]!
Item was added:
+ ----- Method: HaloMorph>>directionArrowLength (in category 'private') -----
+ directionArrowLength
+ ^ 25!
Item was added:
+ ----- Method: HaloMorph>>dismiss (in category 'private') -----
+ dismiss
+ "Remove my target from the world Seems to be EToy specific."
+
+ | w |
+ w := self world.
+ w ifNotNil: [w stopStepping: target].
+ self delete.
+ target dismissViaHalo!
Item was added:
+ ----- Method: HaloMorph>>doDebug:with: (in category 'private') -----
+ doDebug: evt with: menuHandle
+ "Ask hand to invoke the a debugging menu for my inner target. If shift key is down, immediately put up an inspector on the inner target"
+
+ | menu |
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
+ self world displayWorld.
+ evt shiftPressed ifTrue:
+ [self delete.
+ ^ innerTarget inspectInMorphic: evt].
+
+ menu := innerTarget buildDebugMenu: evt hand.
+ menu addTitle: (innerTarget externalName truncateWithElipsisTo: 40).
+ menu popUpEvent: evt in: self world!
Item was added:
+ ----- Method: HaloMorph>>doDirection:with: (in category 'private') -----
+ doDirection: anEvent with: directionHandle
+ anEvent hand obtainHalo: self.
+ self removeAllHandlesBut: directionHandle!
Item was added:
+ ----- Method: HaloMorph>>doDrag:with: (in category 'private') -----
+ doDrag: evt with: dragHandle
+ | thePoint |
+ evt hand obtainHalo: self.
+ thePoint := target point: evt position - positionOffset from: owner.
+ target setConstrainedPosition:(target griddedPoint: thePoint) hangOut: true.
+ !
Item was added:
+ ----- Method: HaloMorph>>doDup:with: (in category 'private') -----
+ doDup: evt with: dupHandle
+ "Ask hand to duplicate my target."
+
+ (target isSelectionMorph) ifTrue:
+ [^ target doDup: evt fromHalo: self handle: dupHandle].
+
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle.
+ self setTarget: (target duplicateMorph: evt).
+ evt hand grabMorph: target.
+ self step. "update position if necessary"
+ evt hand addMouseListener: self. "Listen for the drop"!
Item was added:
+ ----- Method: HaloMorph>>doDupOrMakeSibling:with: (in category 'handles') -----
+ doDupOrMakeSibling: evt with: dupHandle
+ "Ask hand to duplicate my target, if shift key *not* pressed, or make a sibling if shift key *is* pressed"
+
+ ^ (evt shiftPressed and: [target couldMakeSibling])
+ ifTrue:
+ [dupHandle color: Color green muchDarker.
+ self doMakeSibling: evt with: dupHandle]
+ ifFalse:
+ [self doDup: evt with: dupHandle]!
Item was added:
+ ----- Method: HaloMorph>>doGrab:with: (in category 'private') -----
+ doGrab: evt with: grabHandle
+ "Ask hand to grab my target."
+
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: grabHandle.
+ evt hand grabMorph: target.
+ self step. "update position if necessary"
+ evt hand addMouseListener: self. "Listen for the drop"!
Item was added:
+ ----- Method: HaloMorph>>doGrow:with: (in category 'private') -----
+ doGrow: evt with: growHandle
+ "Called while the mouse is down in the grow handle"
+
+ | newExtent extentToUse scale |
+ evt hand obtainHalo: self.
+ newExtent := (target pointFromWorld: (target griddedPoint: evt cursorPoint - positionOffset))
+ - target topLeft.
+ evt shiftPressed ifTrue: [
+ scale := (newExtent x / (originalExtent x max: 1)) min:
+ (newExtent y / (originalExtent y max: 1)).
+ newExtent := (originalExtent x * scale) asInteger @ (originalExtent y * scale) asInteger
+ ].
+ (newExtent x < 1 or: [newExtent y < 1 ]) ifTrue: [^ self].
+ target renderedMorph setExtentFromHalo: (extentToUse := newExtent).
+ growHandle position: evt cursorPoint - (growHandle extent // 2).
+ self layoutChanged.
+ (self valueOfProperty: #commandInProgress) ifNotNil:
+ [:cmd | "Update the final extent"
+ cmd redoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: extentToUse]
+ !
Item was added:
+ ----- Method: HaloMorph>>doMakeSibling:with: (in category 'private') -----
+ doMakeSibling: evt with: dupHandle
+ "Ask hand to make a sibling of my target. Only reachable if target is of a uniclass"
+
+ target couldMakeSibling ifFalse: [^ self].
+
+ target assuredPlayer assureUniClass.
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle.
+ self setTarget: (target makeSiblings: 1) first.
+ evt hand grabMorph: target.
+ self step. "update position if necessary"
+ evt hand addMouseListener: self. "Listen for the drop"!
Item was added:
+ ----- Method: HaloMorph>>doMakeSiblingOrDup:with: (in category 'handles') -----
+ doMakeSiblingOrDup: evt with: dupHandle
+ "Ask hand to duplicate my target, if shift key *is* pressed, or make a sibling if shift key *not* pressed"
+
+ ^ (evt shiftPressed or: [target couldMakeSibling not])
+ ifFalse:
+ [self doMakeSibling: evt with: dupHandle]
+ ifTrue:
+ [dupHandle color: Color green.
+ self doDup: evt with: dupHandle]!
Item was added:
+ ----- Method: HaloMorph>>doMenu:with: (in category 'private') -----
+ doMenu: evt with: menuHandle
+ "Ask hand to invoke the halo menu for my inner target."
+
+ | menu |
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
+ self world displayWorld.
+ menu := innerTarget buildHandleMenu: evt hand.
+ innerTarget addTitleForHaloMenu: menu.
+ menu popUpEvent: evt in: self world.
+ !
Item was added:
+ ----- Method: HaloMorph>>doRecolor:with: (in category 'private') -----
+ doRecolor: evt with: aHandle
+ "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget"
+
+ evt hand obtainHalo: self.
+ (aHandle containsPoint: evt cursorPoint)
+ ifFalse: "only do it if mouse still in handle on mouse up"
+ [self delete.
+ target addHalo: evt]
+ ifTrue:
+ [(Preferences propertySheetFromHalo == evt shiftPressed)
+ ifFalse: [innerTarget openAPropertySheet]
+ ifTrue: [innerTarget changeColor].
+ self showingDirectionHandles ifTrue: [self addHandles]]!
Item was added:
+ ----- Method: HaloMorph>>doRot:with: (in category 'private') -----
+ doRot: evt with: rotHandle
+ "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date."
+
+ | degrees |
+ evt hand obtainHalo: self.
+ degrees := (evt cursorPoint - (target pointInWorld: target referencePosition)) degrees.
+ degrees := degrees - angleOffset degrees.
+ degrees := degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false.
+ degrees = 0.0
+ ifTrue: [self setColor: Color lightBlue toHandle: rotHandle]
+ ifFalse: [self setColor: Color blue toHandle: rotHandle].
+ rotHandle submorphsDo:
+ [:m | m color: rotHandle color makeForegroundColor].
+ self removeAllHandlesBut: rotHandle.
+ self showingDirectionHandles ifFalse:
+ [self showDirectionHandles: true addHandles: false].
+ self addDirectionHandles.
+
+ target rotationDegrees: degrees.
+
+ rotHandle position: evt cursorPoint - (rotHandle extent // 2).
+ (self valueOfProperty: #commandInProgress) ifNotNil:
+ [:cmd | "Update the final rotation"
+ cmd redoTarget: target renderedMorph selector: #heading: argument: degrees].
+ self layoutChanged!
Item was added:
+ ----- Method: HaloMorph>>doScale:with: (in category 'private') -----
+ doScale: evt with: scaleHandle
+ "Update the scale of my target if it is scalable."
+ | newHandlePos colorToUse |
+ evt hand obtainHalo: self.
+ newHandlePos := evt cursorPoint - (scaleHandle extent // 2).
+ target scaleToMatch: newHandlePos.
+ colorToUse := target scale = 1.0
+ ifTrue: [Color yellow]
+ ifFalse: [Color orange].
+ self setColor: colorToUse toHandle: scaleHandle.
+ scaleHandle
+ submorphsDo: [:m | m color: colorToUse makeForegroundColor].
+ scaleHandle position: newHandlePos.
+ self layoutChanged.
+
+ (self valueOfProperty: #commandInProgress) ifNotNil:[:cmd |
+ "Update the final extent"
+ cmd redoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent
+ ].
+ !
Item was added:
+ ----- Method: HaloMorph>>dragTarget: (in category 'events') -----
+ dragTarget: event
+ "Begin dragging the target"
+ | thePoint |
+ event controlKeyPressed ifTrue: [^self growTarget: event].
+ growingOrRotating := false.
+ thePoint := target point: event position - positionOffset from: owner.
+ target setConstrainedPosition: thePoint hangOut: true.
+ event hand newMouseFocus: self.!
Item was added:
+ ----- Method: HaloMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Draw this morph only if it has no target."
+ target isNil
+ ifTrue: [^ super drawOn: aCanvas].
+ (Preferences showBoundsInHalo
+ and: [target isWorldMorph not])
+ ifTrue: [| boundsColor |
+ boundsColor := Preferences menuSelectionColor
+ ifNil: [Color blue].
+ aCanvas
+ frameAndFillRectangle: self bounds
+ fillColor: Color transparent
+ borderWidth: 2
+ borderColor:
+ (boundsColor isTranslucent
+ ifTrue: [boundsColor]
+ ifFalse: [boundsColor alpha: 0.8])]!
Item was added:
+ ----- Method: HaloMorph>>drawSubmorphsOn: (in category 'drawing') -----
+ drawSubmorphsOn: aCanvas
+ | alpha |
+ ((alpha := self magicAlpha) = 1.0)
+ ifTrue:[^super drawSubmorphsOn: aCanvas].
+ ^super drawSubmorphsOn: (aCanvas asAlphaBlendingCanvas: alpha)!
Item was added:
+ ----- Method: HaloMorph>>endInteraction (in category 'private') -----
+ endInteraction
+ "Clean up after a user interaction with the a halo control"
+
+ | m |
+ self isMagicHalo: false. "no longer"
+ self magicAlpha: 1.0.
+ (target isInWorld not or: [owner isNil]) ifTrue: [^self].
+ [target isFlexMorph and: [target hasNoScaleOrRotation]] whileTrue:
+ [m := target firstSubmorph.
+ target removeFlexShell.
+ target := m].
+ self isInWorld
+ ifTrue:
+ ["make sure handles show in front, even if flex shell added"
+
+ self comeToFront.
+ self addHandles].
+ (self valueOfProperty: #commandInProgress) ifNotNil:
+ [:cmd |
+ self rememberCommand: cmd.
+ self removeProperty: #commandInProgress]!
Item was added:
+ ----- Method: HaloMorph>>fadeIn (in category 'stepping') -----
+ fadeIn
+ self magicAlpha >= 1.0 ifTrue:[self stopSteppingSelector: #fadeIn].
+ self magicAlpha: ((self magicAlpha + 0.1) min: 1.0)
+ !
Item was added:
+ ----- Method: HaloMorph>>fadeInInitially (in category 'stepping') -----
+ fadeInInitially
+ | max |
+ max := self isMagicHalo ifTrue:[0.3] ifFalse:[1.0].
+ self magicAlpha >= max ifTrue:[self stopSteppingSelector: #fadeInInitially].
+ self magicAlpha: ((self magicAlpha + (max * 0.1)) min: max)
+ !
Item was added:
+ ----- Method: HaloMorph>>fadeOut (in category 'stepping') -----
+ fadeOut
+ self magicAlpha <= 0.3 ifTrue:[self stopSteppingSelector: #fadeOut].
+ self magicAlpha: ((self magicAlpha - 0.1) max: 0.3)
+ !
Item was added:
+ ----- Method: HaloMorph>>fadeOutFinally (in category 'stepping') -----
+ fadeOutFinally
+ self magicAlpha <= 0.05 ifTrue:[^super delete].
+ self magicAlpha <= 0.3 ifTrue:[
+ ^self magicAlpha: (self magicAlpha - 0.03 max: 0.0)].
+ self magicAlpha: ((self magicAlpha * 0.5) max: 0.0)
+ !
Item was added:
+ ----- Method: HaloMorph>>growTarget: (in category 'events') -----
+ growTarget: event
+ "Begin resizing the target"
+ growingOrRotating := true.
+ positionOffset := event position.
+ originalExtent := target extent.
+ self removeAllHandlesBut: nil.
+ event hand newMouseFocus: self.
+ event hand addMouseListener: self. "add handles back on mouse-up"!
Item was added:
+ ----- Method: HaloMorph>>haloBox: (in category 'accessing') -----
+ haloBox: aBox
+ haloBox := aBox!
Item was added:
+ ----- Method: HaloMorph>>handleAllowanceForIconicHalos (in category 'private') -----
+ handleAllowanceForIconicHalos
+ ^ 12!
Item was added:
+ ----- Method: HaloMorph>>handleEntered (in category 'stepping') -----
+ handleEntered
+ self isMagicHalo ifFalse:[^self].
+ self stopStepping; startStepping.
+ self startSteppingSelector: #fadeIn.
+ !
Item was added:
+ ----- Method: HaloMorph>>handleLeft (in category 'stepping') -----
+ handleLeft
+ self isMagicHalo ifFalse:[^self].
+ self stopStepping; startStepping.
+ self startSteppingSelector: #fadeOut.!
Item was added:
+ ----- Method: HaloMorph>>handleListenEvent: (in category 'events-processing') -----
+ handleListenEvent: anEvent
+ "We listen for possible drop events here to add back those handles after a dup/grab operation"
+
+ (anEvent isMouse and:[anEvent isMove not]) ifFalse:[^ self]. "not interested"
+ anEvent hand removeMouseListener: self. "done listening"
+ (self world ifNil: [target world]) ifNil: [^ self].
+ self addHandles "and get those handles back"!
Item was added:
+ ----- Method: HaloMorph>>handleSize (in category 'private') -----
+ handleSize
+ ^ Preferences biggerHandles
+ ifTrue: [20]
+ ifFalse: [16]!
Item was added:
+ ----- Method: HaloMorph>>handlerForBlueButtonDown: (in category 'meta-actions') -----
+ handlerForBlueButtonDown: anEvent
+ "Blue button was clicked within the receiver"
+ ^self!
Item was added:
+ ----- Method: HaloMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ growingOrRotating := false.
+ simpleMode := Preferences simpleHalosInForce !
Item was added:
+ ----- Method: HaloMorph>>innerTarget (in category 'accessing') -----
+ innerTarget
+
+ ^ innerTarget
+ !
Item was added:
+ ----- Method: HaloMorph>>isMagicHalo (in category 'accessing') -----
+ isMagicHalo
+ ^self valueOfProperty: #isMagicHalo ifAbsent:[false].!
Item was added:
+ ----- Method: HaloMorph>>isMagicHalo: (in category 'accessing') -----
+ isMagicHalo: aBool
+ self setProperty: #isMagicHalo toValue: aBool.
+ aBool ifFalse:[
+ "Reset everything"
+ self stopStepping. "get rid of all"
+ self startStepping. "only those of interest"
+ ].!
Item was added:
+ ----- Method: HaloMorph>>localHaloBoundsFor: (in category 'stepping') -----
+ localHaloBoundsFor: aMorph
+
+ "aMorph may be in the hand and perhaps not in our world"
+
+ | r |
+
+ r := aMorph worldBoundsForHalo truncated.
+ aMorph world = self world ifFalse: [^r].
+ ^((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated!
Item was added:
+ ----- Method: HaloMorph>>magicAlpha (in category 'accessing') -----
+ magicAlpha
+ ^self valueOfProperty: #magicAlpha ifAbsent:[1.0]!
Item was added:
+ ----- Method: HaloMorph>>magicAlpha: (in category 'accessing') -----
+ magicAlpha: alpha
+ self setProperty: #magicAlpha toValue: alpha.
+ self changed.!
Item was added:
+ ----- Method: HaloMorph>>maybeCollapse:with: (in category 'private') -----
+ maybeCollapse: evt with: collapseHandle
+ "Ask hand to collapse my target if mouse comes up in it."
+
+ evt hand obtainHalo: self.
+ self delete.
+ (collapseHandle containsPoint: evt cursorPoint)
+ ifFalse:
+ [
+ target addHalo: evt]
+ ifTrue:
+ [
+ target collapse]!
Item was added:
+ ----- Method: HaloMorph>>maybeDismiss:with: (in category 'private') -----
+ maybeDismiss: evt with: dismissHandle
+ "Ask hand to dismiss my target if mouse comes up in it."
+
+ evt hand obtainHalo: self.
+ (dismissHandle containsPoint: evt cursorPoint)
+ ifFalse:
+ [self delete.
+ target addHalo: evt]
+ ifTrue:
+ [target resistsRemoval ifTrue:
+ [(UIManager default chooseFrom: {
+ 'Yes' translated.
+ 'Um, no, let me reconsider' translated.
+ } title: 'Really throw this away' translated) = 1 ifFalse: [^ self]].
+ evt hand removeHalo.
+ self delete.
+ target dismissViaHalo.
+ ActiveWorld presenter flushPlayerListCache]!
Item was added:
+ ----- Method: HaloMorph>>maybeDoDup:with: (in category 'private') -----
+ maybeDoDup: evt with: dupHandle
+ evt hand obtainHalo: self.
+ ^ target okayToDuplicate ifTrue:
+ [self doDup: evt with: dupHandle]!
Item was added:
+ ----- Method: HaloMorph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+
+ "helpful for insuring some morphs always appear in front of or behind others.
+ smaller numbers are in front"
+
+ ^7 "Halos are very front-like things"!
Item was added:
+ ----- Method: HaloMorph>>mouseDownInCollapseHandle:with: (in category 'private') -----
+ mouseDownInCollapseHandle: evt with: collapseHandle
+ "The mouse went down in the collapse handle; collapse the morph"
+
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: collapseHandle.
+ self setDismissColor: evt with: collapseHandle!
Item was added:
+ ----- Method: HaloMorph>>mouseDownInDimissHandle:with: (in category 'private') -----
+ mouseDownInDimissHandle: evt with: dismissHandle
+ evt hand obtainHalo: self.
+ SoundService soundEnabled ifTrue: [TrashCanMorph playMouseEnterSound].
+ self removeAllHandlesBut: dismissHandle.
+ self setColor: Color darkGray toHandle: dismissHandle.
+ !
Item was added:
+ ----- Method: HaloMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ "Drag our target around or resize it"
+ growingOrRotating
+ ifTrue: [
+ | oldExtent newExtent newPosition |
+ newExtent := originalExtent + (evt position - positionOffset * 2).
+ (newExtent x > 1 and: [newExtent y > 1])
+ ifTrue: [
+ oldExtent := target extent.
+ target setExtentFromHalo: (newExtent min: owner extent).
+ newPosition := target position - (target extent - oldExtent // 2).
+ newPosition := (newPosition x min: owner extent x - newExtent x max: 0) @ (newPosition y min: owner extent y - newExtent y max: 0).
+ target setConstrainedPosition: newPosition hangOut: true]]
+ ifFalse: [
+ | thePoint |
+ thePoint := target point: (evt position - positionOffset) from: owner.
+ target setConstrainedPosition: thePoint hangOut: true.
+ ]!
Item was added:
+ ----- Method: HaloMorph>>obtainHaloForEvent:andRemoveAllHandlesBut: (in category 'private') -----
+ obtainHaloForEvent: evt andRemoveAllHandlesBut: aHandle
+ "Make sure the event's hand correlates with the receiver, and remove all handles except the given one. If nil is provided as the handles argument, the result is that all handles are removed. Note that any pending edits to the name-string in the halo are accepted at this time."
+
+ evt hand obtainHalo: self.
+ self acceptNameEdit.
+ self removeAllHandlesBut: aHandle!
Item was added:
+ ----- Method: HaloMorph>>openViewerForTarget:with: (in category 'handles') -----
+ openViewerForTarget: evt with: aHandle
+ "Open a viewer for my inner target or if shift pressed make a snapshot of morph."
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
+ evt shiftPressed
+ ifTrue: [target duplicateMorphImage: evt]
+ ifFalse: [innerTarget openViewerForArgument]!
Item was added:
+ ----- Method: HaloMorph>>popUpFor:event: (in category 'events') -----
+ popUpFor: aMorph event: evt
+ "This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame."
+
+ | hand anEvent |
+ self flag: #workAround. "We should really have some event/hand here..."
+ anEvent := evt isNil
+ ifTrue:
+ [hand := aMorph world activeHand.
+ hand ifNil: [hand := aMorph world primaryHand].
+ hand lastEvent transformedBy: (aMorph transformedFrom: nil)]
+ ifFalse:
+ [hand := evt hand.
+ evt].
+ self target: aMorph.
+ hand halo: self.
+ hand world addMorphFront: self.
+ positionOffset := anEvent position
+ - (aMorph point: aMorph position in: owner).
+ self startStepping.
+ (Preferences haloTransitions or: [self isMagicHalo])
+ ifTrue:
+ [self magicAlpha: 0.0.
+ self startSteppingSelector: #fadeInInitially]!
Item was added:
+ ----- Method: HaloMorph>>popUpMagicallyFor:hand: (in category 'events') -----
+ popUpMagicallyFor: aMorph hand: aHand
+ "Programatically pop up a halo for a given hand."
+ Preferences magicHalos ifTrue:[
+ self isMagicHalo: true.
+ self magicAlpha: 0.2].
+ self target: aMorph.
+ aHand halo: self.
+ aHand world addMorphFront: self.
+ Preferences haloTransitions ifTrue:[
+ self magicAlpha: 0.0.
+ self startSteppingSelector: #fadeInInitially.
+ ].
+ positionOffset := aHand position - (aMorph point: aMorph position in: owner).
+ self startStepping.!
Item was added:
+ ----- Method: HaloMorph>>position: (in category 'geometry') -----
+ position: pos
+ "Halos display imprefectly if their coordinates are non-integral
+ -- especially the direction handles."
+
+ ^ super position: pos asIntegerPoint!
Item was added:
+ ----- Method: HaloMorph>>positionDirectionShaft: (in category 'private') -----
+ positionDirectionShaft: shaft
+ "Position the shaft."
+ | alphaRadians unitVector |
+ "Pretty crude and slow approach at present, but a stake in the ground"
+ alphaRadians := target heading degreesToRadians.
+ unitVector := alphaRadians sin @ alphaRadians cos negated.
+ shaft setVertices: {unitVector * 6 + directionArrowAnchor. "6 = radius of deadeye circle"
+ unitVector * self directionArrowLength + directionArrowAnchor}
+ !
Item was added:
+ ----- Method: HaloMorph>>positionIn:horizontalPlacement:verticalPlacement: (in category 'handles') -----
+ positionIn: aBox horizontalPlacement: horiz verticalPlacement: vert
+ | xCoord yCoord |
+
+ horiz == #left
+ ifTrue: [xCoord := aBox left].
+ horiz == #leftCenter
+ ifTrue: [xCoord := aBox left + (aBox width // 4)].
+ horiz == #center
+ ifTrue: [xCoord := (aBox left + aBox right) // 2].
+ horiz == #rightCenter
+ ifTrue: [xCoord := aBox left + ((3 * aBox width) // 4)].
+ horiz == #right
+ ifTrue: [xCoord := aBox right].
+
+ vert == #top
+ ifTrue: [yCoord := aBox top].
+ vert == #topCenter
+ ifTrue: [yCoord := aBox top + (aBox height // 4)].
+ vert == #center
+ ifTrue: [yCoord := (aBox top + aBox bottom) // 2].
+ vert == #bottomCenter
+ ifTrue: [yCoord := aBox top + ((3 * aBox height) // 4)].
+ vert == #bottom
+ ifTrue: [yCoord := aBox bottom].
+
+ ^ xCoord asInteger @ yCoord asInteger!
Item was added:
+ ----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') -----
+ prepareToTrackCenterOfRotation: evt with: rotationHandle
+ evt hand obtainHalo: self.
+ evt shiftPressed ifTrue:[
+ self removeAllHandlesBut: rotationHandle.
+ ] ifFalse:[
+ rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
+ self startDrag: evt with: rotationHandle
+ ].
+ evt hand showTemporaryCursor: Cursor blank!
Item was added:
+ ----- Method: HaloMorph>>rejectsEvent: (in category 'events-processing') -----
+ rejectsEvent: anEvent
+ "Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it."
+ (super rejectsEvent: anEvent) ifTrue:[^true].
+ anEvent isDropEvent ifTrue:[^true]. "never attempt to drop on halos"
+ ^false!
Item was added:
+ ----- Method: HaloMorph>>removeAllHandlesBut: (in category 'private') -----
+ removeAllHandlesBut: h
+ "Remove all handles except h."
+ (Preferences maintainHalos and:[h isNil])
+ ifTrue:[self removeHalo]
+ ifFalse:[
+ submorphs copy do:
+ [:m | m == h ifFalse: [m delete]]
+ ].
+ !
Item was added:
+ ----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') -----
+ setCenterOfRotation: evt with: rotationHandle
+ | localPt |
+ evt hand obtainHalo: self.
+ evt hand showTemporaryCursor: nil.
+ (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
+ localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
+ innerTarget setRotationCenterFrom: localPt.
+ ].
+ rotationHandle removeProperty: #dragByCenterOfRotation.
+ self endInteraction
+ !
Item was added:
+ ----- Method: HaloMorph>>setColor:toHandle: (in category 'private') -----
+ setColor: aColor toHandle: aHandle
+ "private - change the color to the given handle, applying the
+ alternate look if corresponds"
+ aHandle color: aColor.
+ Preferences alternateHandlesLook
+ ifTrue: [| fill |
+ fill := GradientFillStyle ramp: {0.0 -> aColor muchLighter. 1.0 -> aColor darker}.
+ fill origin: aHandle topLeft.
+ fill direction: aHandle extent.
+ aHandle fillStyle: fill] !
Item was added:
+ ----- Method: HaloMorph>>setDirection:with: (in category 'private') -----
+ setDirection: anEvent with: directionHandle
+ "The user has let up after having dragged the direction arrow; now set the forward direction of the actual SketchMorph accordingly"
+ anEvent hand obtainHalo: self.
+ target setDirectionFrom: directionHandle center.
+ self endInteraction!
Item was added:
+ ----- Method: HaloMorph>>setDismissColor:with: (in category 'private') -----
+ setDismissColor: evt with: dismissHandle
+ "Called on mouseStillDown in the dismiss handle; set the color appropriately."
+
+ | colorToUse |
+ evt hand obtainHalo: self.
+ colorToUse := (dismissHandle containsPoint: evt cursorPoint)
+ ifFalse:
+ [Color red muchLighter]
+ ifTrue:
+ [Color lightGray].
+ self setColor: colorToUse toHandle: dismissHandle.
+ !
Item was added:
+ ----- Method: HaloMorph>>setTarget: (in category 'accessing') -----
+ setTarget: aMorph
+ "Private!! Set the target without adding handles."
+
+ target := aMorph topRendererOrSelf.
+ innerTarget := target renderedMorph.
+ innerTarget wantsDirectionHandles
+ ifTrue: [self showDirectionHandles: true addHandles: false].
+ target hasHalo: true.
+
+ !
Item was added:
+ ----- Method: HaloMorph>>showDirectionHandles: (in category 'private') -----
+ showDirectionHandles: wantToShow
+
+ self showDirectionHandles: wantToShow addHandles: true "called from menu"
+ !
Item was added:
+ ----- Method: HaloMorph>>showDirectionHandles:addHandles: (in category 'private') -----
+ showDirectionHandles: wantToShow addHandles: needHandles
+ directionArrowAnchor := wantToShow
+ ifTrue: [target referencePositionInWorld "not nil means show"]
+ ifFalse: [nil].
+ needHandles ifTrue: [self addHandles] !
Item was added:
+ ----- Method: HaloMorph>>showingDirectionHandles (in category 'private') -----
+ showingDirectionHandles
+ ^directionArrowAnchor notNil!
Item was added:
+ ----- Method: HaloMorph>>simpleFudgeOffset (in category 'private') -----
+ simpleFudgeOffset
+ "account for the difference in basicBoxes between regular and simple handles"
+
+ ^ 0 at 0
+ !
Item was added:
+ ----- Method: HaloMorph>>startDrag:with: (in category 'dropping/grabbing') -----
+ startDrag: evt with: dragHandle
+ "Drag my target without removing it from its owner."
+
+ | itsOwner |
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: dragHandle.
+ positionOffset := dragHandle center - (target point: target position in: owner).
+
+ ((itsOwner := target topRendererOrSelf owner) notNil and:
+ [itsOwner automaticViewing]) ifTrue:
+ [target openViewerForArgument]!
Item was added:
+ ----- Method: HaloMorph>>startGrow:with: (in category 'private') -----
+ startGrow: evt with: growHandle
+ "Initialize resizing of my target. Launch a command representing it, to support Undo"
+
+ | botRt |
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: growHandle.
+ botRt := target point: target bottomRight in: owner.
+ positionOffset := (self world viewBox containsPoint: botRt)
+ ifTrue: [evt cursorPoint - botRt]
+ ifFalse: [0 at 0].
+
+ self setProperty: #commandInProgress toValue:
+ (Command new
+ cmdWording: ('resize ' translated, target nameForUndoWording);
+ undoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent).
+
+ originalExtent := target extent!
Item was added:
+ ----- Method: HaloMorph>>startRot:with: (in category 'private') -----
+ startRot: evt with: rotHandle
+ "Initialize rotation of my target if it is rotatable. Launch a command object to represent the action"
+
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: rotHandle.
+ target isFlexMorph ifFalse:
+ [target isInWorld ifFalse: [self setTarget: target player costume].
+ target addFlexShellIfNecessary].
+ growingOrRotating := true.
+
+ self removeAllHandlesBut: rotHandle. "remove all other handles"
+ angleOffset := evt cursorPoint - (target pointInWorld: target referencePosition).
+ angleOffset := Point
+ r: angleOffset r
+ degrees: angleOffset degrees - target rotationDegrees.
+ self setProperty: #commandInProgress toValue:
+ (Command new
+ cmdWording: ('rotate ' translated, target nameForUndoWording);
+ undoTarget: target renderedMorph selector: #heading: argument: target rotationDegrees)
+
+ !
Item was added:
+ ----- Method: HaloMorph>>startScale:with: (in category 'private') -----
+ startScale: evt with: scaleHandle
+ "Initialize scaling of my target."
+
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: scaleHandle.
+ target isFlexMorph ifFalse: [target addFlexShellIfNecessary].
+ growingOrRotating := true.
+ positionOffset := 0 at 0.
+
+ self setProperty: #commandInProgress toValue:
+ (Command new
+ cmdWording: ('resize ' translated, target nameForUndoWording);
+ undoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent).
+ originalExtent := target extent
+ !
Item was added:
+ ----- Method: HaloMorph>>staysUpWhenMouseIsDownIn: (in category 'events') -----
+ staysUpWhenMouseIsDownIn: aMorph
+ ^ ((aMorph == target) or: [aMorph hasOwner: self])!
Item was added:
+ ----- Method: HaloMorph>>step (in category 'stepping') -----
+ step
+ | newBounds |
+ target
+ ifNil: [^ self].
+ newBounds := target isWorldMorph
+ ifTrue: [target bounds]
+ ifFalse: [self localHaloBoundsFor: target renderedMorph].
+ newBounds = self bounds
+ ifTrue: [^ self].
+ newBounds extent = self bounds extent
+ ifTrue: [^ self position: newBounds origin].
+ growingOrRotating
+ ifFalse: [submorphs size > 1
+ ifTrue: [self addHandles]].
+ "adjust halo bounds if appropriate"
+ self bounds: newBounds!
Item was added:
+ ----- Method: HaloMorph>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ 0 "every cycle"
+ !
Item was added:
+ ----- Method: HaloMorph>>target (in category 'accessing') -----
+ target
+
+ ^ target
+ !
Item was added:
+ ----- Method: HaloMorph>>target: (in category 'accessing') -----
+ target: aMorph
+
+ self setTarget: aMorph.
+ target ifNotNil: [self addHandles].
+ !
Item was added:
+ ----- Method: HaloMorph>>tearOffTileForTarget:with: (in category 'handles') -----
+ tearOffTileForTarget: evt with: aHandle
+ "Tear off a tile representing my inner target. If shift key is down, open up an instance browser on the morph itself, not the player, with tiles showing, instead"
+
+ self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil.
+ innerTarget tearOffTile!
Item was added:
+ ----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') -----
+ trackCenterOfRotation: anEvent with: rotationHandle
+ (rotationHandle hasProperty: #dragByCenterOfRotation)
+ ifTrue:[^self doDrag: anEvent with: rotationHandle].
+ anEvent hand obtainHalo: self.
+ rotationHandle center: anEvent cursorPoint.!
Item was added:
+ ----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') -----
+ trackDirectionArrow: anEvent with: shaft
+ anEvent hand obtainHalo: self.
+ shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
+ self layoutChanged!
Item was added:
+ ----- Method: HaloMorph>>transferHalo: (in category 'events') -----
+ transferHalo: event
+ "Transfer the halo to the next likely recipient"
+ target ifNil:[^self delete].
+ target transferHalo: (event transformedBy: (target transformedFrom: self)) from: target.!
Item was added:
+ ----- Method: HaloMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ target := deepCopier references at: target ifAbsent: [target].
+ innerTarget := deepCopier references at: innerTarget ifAbsent: [innerTarget].
+ !
Item was added:
+ ----- Method: HaloMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ "target := target. Weakly copied"
+ "innerTarget := innerTarget. Weakly copied"
+ positionOffset := positionOffset veryDeepCopyWith: deepCopier.
+ angleOffset := angleOffset veryDeepCopyWith: deepCopier.
+ growingOrRotating := growingOrRotating veryDeepCopyWith: deepCopier.
+ directionArrowAnchor := directionArrowAnchor.
+ simpleMode := simpleMode.
+ haloBox := haloBox.
+ originalExtent := originalExtent
+ !
Item was added:
+ ----- Method: HaloMorph>>wantsKeyboardFocusFor: (in category 'event handling') -----
+ wantsKeyboardFocusFor: aSubmorph
+ "to allow the name to be edited in the halo in the old tty way; when we morphic-text-ize the name editing, presumably this method should be removed"
+ ^ true!
Item was added:
+ ----- Method: HaloMorph>>wantsToBeTopmost (in category 'accessing') -----
+ wantsToBeTopmost
+ "Answer if the receiver want to be one of the topmost objects in
+ its owner"
+ ^ true!
Item was added:
+ ----- Method: HaloMorph>>wantsYellowButtonMenu (in category 'menu') -----
+ wantsYellowButtonMenu
+ "Answer true if the receiver wants a yellow button menu"
+ ^ false!
Item was added:
+ Object subclass: #HaloSpec
+ instanceVariableNames: 'addHandleSelector horizontalPlacement verticalPlacement color iconSymbol'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !HaloSpec commentStamp: 'kfr 10/27/2003 16:23' prior: 0!
+ Sets spec's for how handles are layed out in a halo.!
Item was added:
+ ----- Method: HaloSpec>>addHandleSelector (in category 'as yet unclassified') -----
+ addHandleSelector
+ ^ addHandleSelector!
Item was added:
+ ----- Method: HaloSpec>>color (in category 'as yet unclassified') -----
+ color
+ ^ color!
Item was added:
+ ----- Method: HaloSpec>>horizontalPlacement (in category 'as yet unclassified') -----
+ horizontalPlacement
+ ^ horizontalPlacement!
Item was added:
+ ----- Method: HaloSpec>>horizontalPlacement:verticalPlacement:color:iconSymbol:addHandleSelector: (in category 'as yet unclassified') -----
+ horizontalPlacement: hp verticalPlacement: vp color: col iconSymbol: is addHandleSelector: sel
+ horizontalPlacement := hp.
+ verticalPlacement := vp.
+ color:= col.
+ iconSymbol := is asSymbol.
+ addHandleSelector := sel!
Item was added:
+ ----- Method: HaloSpec>>iconSymbol (in category 'as yet unclassified') -----
+ iconSymbol
+ ^ iconSymbol!
Item was added:
+ ----- Method: HaloSpec>>printOn: (in category 'printing') -----
+ printOn: aStream
+ "Add a textual printout representing the receiver to a stream"
+
+ super printOn: aStream.
+ aStream nextPutAll: ' (', addHandleSelector asString, ' ', iconSymbol asString, ')'!
Item was added:
+ ----- Method: HaloSpec>>verticalPlacement (in category 'as yet unclassified') -----
+ verticalPlacement
+ ^ verticalPlacement!
Item was added:
+ Morph subclass: #HandMorph
+ instanceVariableNames: 'mouseFocus keyboardFocus eventListeners mouseListeners keyboardListeners mouseClickState mouseOverHandler lastMouseEvent targetOffset damageRecorder cacheCanvas cachedCanvasHasHoles temporaryCursor temporaryCursorOffset hardwareCursor hasChanged savedPatch userInitials lastEventBuffer genieGestureProcessor keyboardInterpreter'
+ classVariableNames: 'CompositionWindowManager DoubleClickTime DragThreshold EventStats NewEventRules NormalCursor PasteBuffer ShowEvents'
+ poolDictionaries: 'EventSensorConstants'
+ category: 'Morphic-Kernel'!
+
+ !HandMorph commentStamp: '<historical>' prior: 0!
+ The cursor may be thought of as the HandMorph. The hand's submorphs hold anything being carried by dragging.
+
+ There is some minimal support for multiple hands in the same world.!
Item was added:
+ ----- Method: HandMorph class>>attach: (in category 'utilities') -----
+ attach: aMorph
+ "Attach aMorph the current world's primary hand."
+
+ self currentWorld primaryHand attachMorph: aMorph!
Item was added:
+ ----- Method: HandMorph class>>clearCompositionWindowManager (in category 'initialization') -----
+ clearCompositionWindowManager
+
+ CompositionWindowManager := nil.
+ !
Item was added:
+ ----- Method: HandMorph class>>clearInterpreters (in category 'initialization') -----
+ clearInterpreters
+
+ self allInstances do: [:each | each clearKeyboardInterpreter].
+ !
Item was added:
+ ----- Method: HandMorph class>>compositionWindowManager (in category 'accessing') -----
+ compositionWindowManager
+ CompositionWindowManager ifNotNil: [^CompositionWindowManager].
+ Smalltalk platformName = 'Win32'
+ ifTrue: [^CompositionWindowManager := ImmWin32 new].
+ (Smalltalk platformName = 'unix'
+ and: [(Smalltalk windowSystemName) = 'X11'])
+ ifTrue: [^CompositionWindowManager := ImmX11 new].
+ ^CompositionWindowManager := ImmAbstractPlatform new!
Item was added:
+ ----- Method: HandMorph class>>doubleClickTime (in category 'accessing') -----
+ doubleClickTime
+
+ ^ DoubleClickTime
+ !
Item was added:
+ ----- Method: HandMorph class>>doubleClickTime: (in category 'accessing') -----
+ doubleClickTime: milliseconds
+
+ DoubleClickTime := milliseconds.
+ !
Item was added:
+ ----- Method: HandMorph class>>dragThreshold (in category 'accessing') -----
+ dragThreshold
+
+ ^ DragThreshold
+ !
Item was added:
+ ----- Method: HandMorph class>>dragThreshold: (in category 'accessing') -----
+ dragThreshold: pixels
+
+ DragThreshold := pixels!
Item was added:
+ ----- Method: HandMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ "Not to be instantiated from the menu"
+ ^ false!
Item was added:
+ ----- Method: HandMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "HandMorph initialize"
+ PasteBuffer := nil.
+ DoubleClickTime := 350 "milliseconds".
+ DragThreshold := 10 "pixels".
+ NormalCursor := CursorWithMask normal asCursorForm!
Item was added:
+ ----- Method: HandMorph class>>localeChanged (in category 'class initialization') -----
+ localeChanged
+ self startUp.!
Item was added:
+ ----- Method: HandMorph class>>newEventRules: (in category 'utilities') -----
+ newEventRules: aBool
+ NewEventRules := aBool.!
Item was added:
+ ----- Method: HandMorph class>>showEvents: (in category 'utilities') -----
+ showEvents: aBool
+ "HandMorph showEvents: true"
+ "HandMorph showEvents: false"
+ ShowEvents := aBool.
+ aBool ifFalse: [ ActiveWorld invalidRect: (0 at 0 extent: 250 at 120) ].!
Item was added:
+ ----- Method: HandMorph class>>startUp (in category 'initialization') -----
+ startUp
+
+ self clearCompositionWindowManager.
+ self clearInterpreters.
+ !
Item was added:
+ ----- Method: HandMorph>>addEventListener: (in category 'listeners') -----
+ addEventListener: anObject
+ "Make anObject a listener for all events. All events will be reported to the object."
+ self eventListeners: (self addListener: anObject to: self eventListeners)!
Item was added:
+ ----- Method: HandMorph>>addKeyboardListener: (in category 'listeners') -----
+ addKeyboardListener: anObject
+ "Make anObject a listener for keyboard events. All keyboard events will be reported to the object."
+ self keyboardListeners: (self addListener: anObject to: self keyboardListeners)!
Item was added:
+ ----- Method: HandMorph>>addListener:to: (in category 'listeners') -----
+ addListener: anObject to: aListenerGroup
+ "Add anObject to the given listener group. Return the new group."
+ | listeners |
+ listeners := aListenerGroup.
+ (listeners notNil and:[listeners includes: anObject]) ifFalse:[
+ listeners
+ ifNil:[listeners := WeakArray with: anObject]
+ ifNotNil:[listeners := listeners copyWith: anObject]].
+ listeners := listeners copyWithout: nil. "obsolete entries"
+ ^listeners!
Item was added:
+ ----- Method: HandMorph>>addMouseListener: (in category 'listeners') -----
+ addMouseListener: anObject
+ "Make anObject a listener for mouse events. All mouse events will be reported to the object."
+ self mouseListeners: (self addListener: anObject to: self mouseListeners)!
Item was added:
+ ----- Method: HandMorph>>anyButtonPressed (in category 'accessing') -----
+ anyButtonPressed
+ ^lastMouseEvent anyButtonPressed!
Item was added:
+ ----- Method: HandMorph>>attachMorph: (in category 'grabbing/dropping') -----
+ attachMorph: m
+ "Position the center of the given morph under this hand, then grab it.
+ This method is used to grab far away or newly created morphs."
+ | delta |
+ self releaseMouseFocus. "Break focus"
+ delta := m bounds extent // 2.
+ m position: (self position - delta).
+ m formerPosition: m position.
+ targetOffset := m position - self position.
+ self addMorphBack: m.!
Item was added:
+ ----- Method: HandMorph>>autoFocusRectangleBoundsFor: (in category 'genie-stubs') -----
+ autoFocusRectangleBoundsFor: aMorph
+ ^aMorph bounds!
Item was added:
+ ----- Method: HandMorph>>balloonHelp (in category 'balloon help') -----
+ balloonHelp
+ "Return the balloon morph associated with this hand"
+ ^self valueOfProperty: #balloonHelpMorph!
Item was added:
+ ----- Method: HandMorph>>balloonHelp: (in category 'balloon help') -----
+ balloonHelp: aBalloonMorph
+ "Return the balloon morph associated with this hand"
+ | oldHelp |
+ oldHelp := self balloonHelp.
+ oldHelp ifNotNil:[oldHelp delete].
+ aBalloonMorph
+ ifNil:[self removeProperty: #balloonHelpMorph]
+ ifNotNil:[self setProperty: #balloonHelpMorph toValue: aBalloonMorph]!
Item was added:
+ ----- Method: HandMorph>>changed (in category 'updating') -----
+ changed
+
+ hasChanged := true.
+ !
Item was added:
+ ----- Method: HandMorph>>checkForMoreKeyboard (in category 'event handling') -----
+ checkForMoreKeyboard
+ "Quick check for more keyboard activity -- Allows, eg, many characters
+ to be accumulated into a single replacement during type-in."
+
+ | evtBuf |
+ self flag: #arNote. "Will not work if we don't examine event queue in Sensor"
+ evtBuf := Sensor peekKeyboardEvent.
+ evtBuf ifNil: [^nil].
+ ^self generateKeyboardEvent: evtBuf!
Item was added:
+ ----- Method: HandMorph>>clearKeyboardInterpreter (in category 'multilingual') -----
+ clearKeyboardInterpreter
+
+ keyboardInterpreter := nil.
+ !
Item was added:
+ ----- Method: HandMorph>>colorForInsets (in category 'accessing') -----
+ colorForInsets
+ "Morphs being dragged by the hand use the world's color"
+ ^ owner colorForInsets!
Item was added:
+ ----- Method: HandMorph>>compositionWindowManager (in category 'focus handling') -----
+ compositionWindowManager
+
+ ^ self class compositionWindowManager.
+ !
Item was added:
+ ----- Method: HandMorph>>copyToPasteBuffer: (in category 'meta-actions') -----
+ copyToPasteBuffer: aMorph
+ "Save this morph in the paste buffer. This is mostly useful for copying morphs between projects."
+ aMorph ifNil:[^PasteBuffer := nil].
+ Cursor wait showWhile:[
+ PasteBuffer := aMorph topRendererOrSelf veryDeepCopy.
+ PasteBuffer privateOwner: nil].
+
+ !
Item was added:
+ ----- Method: HandMorph>>cursorBounds (in category 'cursor') -----
+ cursorBounds
+
+ ^temporaryCursor
+ ifNil: [self position extent: NormalCursor extent]
+ ifNotNil: [self position + temporaryCursorOffset extent: temporaryCursor extent]!
Item was added:
+ ----- Method: HandMorph>>cursorPoint (in category 'event handling') -----
+ cursorPoint
+ "Implemented for allowing embedded worlds in an event cycle to query a hand's position and get it in its coordinates. The same can be achieved by #point:from: but this is simply much more convenient since it will look as if the hand is in the lower world."
+
+ | pos |
+ pos := self position.
+ (ActiveWorld isNil or: [ActiveWorld == owner]) ifTrue: [^pos].
+ ^ActiveWorld point: pos from: owner!
Item was added:
+ ----- Method: HandMorph>>deleteBalloonTarget: (in category 'balloon help') -----
+ deleteBalloonTarget: aMorph
+ "Delete any existing balloon help. This is now done unconditionally, whether or not the morph supplied is the same as the current balloon target"
+
+ self balloonHelp: nil
+
+ " | h |
+ h := self balloonHelp ifNil: [^ self].
+ h balloonOwner == aMorph ifTrue: [self balloonHelp: nil]"!
Item was added:
+ ----- Method: HandMorph>>disableGenieFocus (in category 'genie-stubs') -----
+ disableGenieFocus
+ !
Item was added:
+ ----- Method: HandMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Draw the hand itself (i.e., the cursor)."
+
+ | userPic |
+ temporaryCursor isNil
+ ifTrue: [aCanvas paintImage: NormalCursor at: bounds topLeft]
+ ifFalse: [aCanvas paintImage: temporaryCursor at: bounds topLeft].
+ self hasUserInformation
+ ifTrue:
+ [aCanvas
+ drawString: userInitials
+ at: self cursorBounds topRight + (0 @ 4)
+ font: nil
+ color: color.
+ (userPic := self userPicture) ifNotNil:
+ [aCanvas paintImage: userPic at: self cursorBounds topRight + (0 @ 24)]]!
Item was added:
+ ----- Method: HandMorph>>dropMorph:event: (in category 'grabbing/dropping') -----
+ dropMorph: aMorph event: anEvent
+ "Drop the given morph which was carried by the hand"
+ | event dropped |
+ (anEvent isMouseUp and:[aMorph shouldDropOnMouseUp not]) ifTrue:[^self].
+
+ "Note: For robustness in drag and drop handling we remove the morph BEFORE we drop him, but we keep his owner set to the hand. This prevents system lockups when there is a problem in drop handling (for example if there's an error in #wantsToBeDroppedInto:). THIS TECHNIQUE IS NOT RECOMMENDED FOR CASUAL USE."
+ self privateRemove: aMorph.
+ aMorph privateOwner: self.
+
+ dropped := aMorph.
+ (dropped hasProperty: #addedFlexAtGrab)
+ ifTrue:[dropped := aMorph removeFlexShell].
+ event := DropEvent new setPosition: self position contents: dropped hand: self.
+ self sendEvent: event focus: nil.
+ event wasHandled ifFalse:[aMorph rejectDropMorphEvent: event].
+ aMorph owner == self ifTrue:[aMorph delete].
+ self mouseOverHandler processMouseOver: anEvent.!
Item was added:
+ ----- Method: HandMorph>>dropMorphs (in category 'grabbing/dropping') -----
+ dropMorphs
+ "Drop the morphs at the hands position"
+ self dropMorphs: lastMouseEvent.!
Item was added:
+ ----- Method: HandMorph>>dropMorphs: (in category 'grabbing/dropping') -----
+ dropMorphs: anEvent
+ "Drop the morphs at the hands position"
+ self submorphsReverseDo:[:m|
+ "Drop back to front to maintain z-order"
+ self dropMorph: m event: anEvent.
+ ].!
Item was added:
+ ----- Method: HandMorph>>enableGenie (in category 'genie-stubs') -----
+ enableGenie
+ self error: 'Genie is not available for this hand'.!
Item was added:
+ ----- Method: HandMorph>>eventListeners (in category 'listeners') -----
+ eventListeners
+ ^eventListeners!
Item was added:
+ ----- Method: HandMorph>>eventListeners: (in category 'listeners') -----
+ eventListeners: anArrayOrNil
+ eventListeners := anArrayOrNil!
Item was added:
+ ----- Method: HandMorph>>flushEvents (in category 'event handling') -----
+ flushEvents
+ "Flush any events that may be pending"
+ self flag: #arNote. "Remove it and fix senders"
+ Sensor flushEvents.!
Item was added:
+ ----- Method: HandMorph>>focusStartEvent (in category 'genie-stubs') -----
+ focusStartEvent
+ ^nil!
Item was added:
+ ----- Method: HandMorph>>fullBounds (in category 'layout') -----
+ fullBounds
+ "Extend my bounds by the shadow offset when carrying morphs."
+
+ | bnds |
+ bnds := super fullBounds.
+ submorphs isEmpty
+ ifTrue: [^ bnds ]
+ ifFalse: [^ bnds topLeft corner: bnds bottomRight + self shadowOffset].
+ !
Item was added:
+ ----- Method: HandMorph>>fullDrawOn: (in category 'drawing') -----
+ fullDrawOn: aCanvas
+ "A HandMorph has unusual drawing requirements:
+ 1. the hand itself (i.e., the cursor) appears in front of its submorphs
+ 2. morphs being held by the hand cast a shadow on the world/morphs below
+ The illusion is that the hand plucks up morphs and carries them above the world."
+
+ "Note: This version caches an image of the morphs being held by the hand for
+ better performance. This cache is invalidated if one of those morphs changes."
+
+ | disableCaching subBnds |
+ self visible ifFalse: [^self].
+ (aCanvas isVisible: self fullBounds) ifFalse: [^self].
+ (self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas].
+ disableCaching := false.
+ disableCaching
+ ifTrue:
+ [self nonCachingFullDrawOn: aCanvas.
+ ^self].
+ submorphs isEmpty
+ ifTrue:
+ [cacheCanvas := nil.
+ ^self drawOn: aCanvas]. "just draw the hand itself"
+ subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]).
+ self updateCacheCanvas: aCanvas.
+ (cacheCanvas isNil
+ or: [cachedCanvasHasHoles and: [cacheCanvas depth = 1]])
+ ifTrue:
+ ["could not use caching due to translucency; do full draw"
+
+ self nonCachingFullDrawOn: aCanvas.
+ ^self].
+
+ "draw the shadow"
+ aCanvas asShadowDrawingCanvas translateBy: self shadowOffset
+ during:
+ [:shadowCanvas |
+ cachedCanvasHasHoles
+ ifTrue:
+ ["Have to draw the real shadow of the form"
+
+ shadowCanvas paintImage: cacheCanvas form at: subBnds origin]
+ ifFalse:
+ ["Much faster if only have to shade the edge of a solid rectangle"
+
+ (subBnds areasOutside: (subBnds translateBy: self shadowOffset negated))
+ do: [:r | shadowCanvas fillRectangle: r color: Color black]]].
+
+ "draw morphs in front of the shadow using the cached Form"
+ cachedCanvasHasHoles
+ ifTrue: [aCanvas paintImage: cacheCanvas form at: subBnds origin]
+ ifFalse:
+ [aCanvas
+ drawImage: cacheCanvas form
+ at: subBnds origin
+ sourceRect: cacheCanvas form boundingBox].
+ self drawOn: aCanvas "draw the hand itself in front of morphs"!
Item was added:
+ ----- Method: HandMorph>>generateDropFilesEvent: (in category 'private events') -----
+ generateDropFilesEvent: evtBuf
+ "Generate the appropriate mouse event for the given raw event buffer"
+
+ "Note: This is still in an experimental phase and will need more work"
+
+ | position buttons modifiers stamp numFiles dragType |
+ stamp := evtBuf second.
+ stamp = 0 ifTrue: [stamp := Time millisecondClockValue].
+ dragType := evtBuf third.
+ position := evtBuf fourth @ evtBuf fifth.
+ buttons := 0.
+ modifiers := evtBuf sixth.
+ buttons := buttons bitOr: (modifiers bitShift: 3).
+ numFiles := evtBuf seventh.
+ dragType = 4
+ ifTrue:
+ ["e.g., drop"
+
+ owner borderWidth: 0.
+ ^DropFilesEvent new
+ setPosition: position
+ contents: numFiles
+ hand: self].
+ "the others are currently not handled by morphs themselves"
+ dragType = 1
+ ifTrue:
+ ["experimental drag enter"
+
+ owner
+ borderWidth: 4;
+ borderColor: owner color asColor negated].
+ dragType = 2
+ ifTrue:
+ ["experimental drag move"
+
+ ].
+ dragType = 3
+ ifTrue:
+ ["experimental drag leave"
+
+ owner borderWidth: 0].
+ ^nil!
Item was added:
+ ----- Method: HandMorph>>generateKeyboardEvent: (in category 'private events') -----
+ generateKeyboardEvent: evtBuf
+ "Generate the appropriate mouse event for the given raw event buffer"
+
+ | buttons modifiers type pressType stamp keyValue |
+ stamp := evtBuf second.
+ stamp = 0 ifTrue: [stamp := Time millisecondClockValue].
+ pressType := evtBuf fourth.
+ pressType = EventKeyDown ifTrue: [type := #keyDown].
+ pressType = EventKeyUp ifTrue: [type := #keyUp].
+ pressType = EventKeyChar ifTrue: [type := #keystroke].
+ modifiers := evtBuf fifth.
+ buttons := (modifiers bitShift: 3) bitOr: (lastMouseEvent buttons bitAnd: 7).
+ type = #keystroke
+ ifTrue: [keyValue := (self keyboardInterpreter nextCharFrom: Sensor firstEvt: evtBuf) asInteger]
+ ifFalse: [keyValue := evtBuf third].
+ ^ KeyboardEvent new
+ setType: type
+ buttons: buttons
+ position: self position
+ keyValue: keyValue
+ hand: self
+ stamp: stamp.
+ !
Item was added:
+ ----- Method: HandMorph>>generateMouseEvent: (in category 'private events') -----
+ generateMouseEvent: evtBuf
+ "Generate the appropriate mouse event for the given raw event buffer"
+
+ | position buttons modifiers type trail stamp oldButtons evtChanged |
+ evtBuf first = lastEventBuffer first
+ ifTrue:
+ ["Workaround for Mac VM bug, *always* generating 3 events on clicks"
+
+ evtChanged := false.
+ 3 to: evtBuf size
+ do: [:i | (lastEventBuffer at: i) = (evtBuf at: i) ifFalse: [evtChanged := true]].
+ evtChanged ifFalse: [^nil]].
+ stamp := evtBuf second.
+ stamp = 0 ifTrue: [stamp := Time millisecondClockValue].
+ position := evtBuf third @ evtBuf fourth.
+ buttons := evtBuf fifth.
+ modifiers := evtBuf sixth.
+
+ type := buttons = 0
+ ifTrue:[
+ lastEventBuffer fifth = 0
+ ifTrue: [#mouseMove] "this time no button and previously no button .. just mouse move"
+ ifFalse: [#mouseUp] "this time no button but previously some button ... therefore button was released"
+ ]
+ ifFalse:[
+ buttons = lastEventBuffer fifth
+ ifTrue: [#mouseMove] "button states are the same .. now and past .. therfore a mouse movement"
+ ifFalse: [ "button states are different .. button was pressed or released"
+ buttons > lastEventBuffer fifth
+ ifTrue: [#mouseDown]
+ ifFalse:[#mouseUp].
+ ].
+ ].
+ buttons := buttons bitOr: (modifiers bitShift: 3).
+ oldButtons := lastEventBuffer fifth
+ bitOr: (lastEventBuffer sixth bitShift: 3).
+ lastEventBuffer := evtBuf.
+ type == #mouseMove
+ ifTrue:
+ [trail := self mouseTrailFrom: evtBuf.
+ ^MouseMoveEvent new
+ setType: type
+ startPoint: (self position)
+ endPoint: trail last
+ trail: trail
+ buttons: buttons
+ hand: self
+ stamp: stamp].
+ ^MouseButtonEvent new
+ setType: type
+ position: position
+ which: (oldButtons bitXor: buttons)
+ buttons: buttons
+ hand: self
+ stamp: stamp!
Item was added:
+ ----- Method: HandMorph>>generateWindowEvent: (in category 'private events') -----
+ generateWindowEvent: evtBuf
+ "Generate the appropriate window event for the given raw event buffer"
+
+ | evt |
+ evt := WindowEvent new.
+ evt setTimeStamp: evtBuf second.
+ evt timeStamp = 0 ifTrue: [evt setTimeStamp: Time millisecondClockValue].
+ evt action: evtBuf third.
+ evt rectangle: (Rectangle origin: evtBuf fourth @ evtBuf fifth corner: evtBuf sixth @ evtBuf seventh ).
+
+ ^evt!
Item was added:
+ ----- Method: HandMorph>>genieGestureProcessor (in category 'genie-stubs') -----
+ genieGestureProcessor
+ ^nil!
Item was added:
+ ----- Method: HandMorph>>grabMorph: (in category 'meta-actions') -----
+ grabMorph: aMorph
+ "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand."
+ | grabbed |
+ self releaseMouseFocus. "Break focus"
+ grabbed := aMorph aboutToBeGrabbedBy: self.
+ grabbed ifNil:[^self].
+ grabbed := grabbed topRendererOrSelf.
+ ^self grabMorph: grabbed from: grabbed owner!
Item was added:
+ ----- Method: HandMorph>>grabMorph:from: (in category 'grabbing/dropping') -----
+ grabMorph: aMorph from: formerOwner
+ "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand."
+
+ | grabbed offset targetPoint grabTransform fullTransform |
+ self releaseMouseFocus. "Break focus"
+ grabbed := aMorph.
+ aMorph keepsTransform ifTrue:[
+ grabTransform := fullTransform := IdentityTransform new.
+ ] ifFalse:[
+ "Compute the transform to apply to the grabbed morph"
+ grabTransform := formerOwner
+ ifNil: [IdentityTransform new]
+ ifNotNil: [formerOwner grabTransform].
+ "Compute the full transform for the grabbed morph"
+ fullTransform := formerOwner
+ ifNil: [IdentityTransform new]
+ ifNotNil: [formerOwner transformFrom: owner].
+ ].
+ "targetPoint is point in aMorphs reference frame"
+ targetPoint := fullTransform globalPointToLocal: self position.
+ "but current position will be determined by grabTransform, so compute offset"
+ offset := targetPoint - (grabTransform globalPointToLocal: self position).
+ "apply the transform that should be used after grabbing"
+ grabbed := grabbed transformedBy: grabTransform.
+ grabbed == aMorph
+ ifFalse: [grabbed setProperty: #addedFlexAtGrab toValue: true].
+ "offset target to compensate for differences in transforms"
+ grabbed position: grabbed position - offset asIntegerPoint.
+ "And compute distance from hand's position"
+ targetOffset := grabbed position - self position.
+ self addMorphBack: grabbed.
+ grabbed justGrabbedFrom: formerOwner.!
Item was added:
+ ----- Method: HandMorph>>halo (in category 'halos and balloon help') -----
+ halo
+ "Return the halo associated with this hand, if any"
+ ^self valueOfProperty: #halo!
Item was added:
+ ----- Method: HandMorph>>halo: (in category 'halo handling') -----
+ halo: newHalo
+ "Set halo associated with this hand"
+ | oldHalo |
+ oldHalo := self halo.
+ (oldHalo isNil or:[oldHalo == newHalo]) ifFalse:[oldHalo delete].
+ newHalo
+ ifNil:[self removeProperty: #halo]
+ ifNotNil:[self setProperty: #halo toValue: newHalo]!
Item was added:
+ ----- Method: HandMorph>>handleEvent: (in category 'events-processing') -----
+ handleEvent: anEvent
+ | evt ofs |
+ owner ifNil:[^self].
+ evt := anEvent.
+
+ EventStats ifNil:[EventStats := IdentityDictionary new].
+ EventStats at: #count put: (EventStats at: #count ifAbsent:[0]) + 1.
+ EventStats at: evt type put: (EventStats at: evt type ifAbsent:[0]) + 1.
+
+ evt isMouseOver ifTrue:[^self sendMouseEvent: evt].
+
+ ShowEvents == true ifTrue:[
+ Display fill: (0 at 0 extent: 250 at 120) rule: Form over fillColor: Color white.
+ ofs := (owner hands indexOf: self) - 1 * 60.
+ evt printString displayAt: (0 at ofs) + (evt isKeyboard ifTrue:[0 at 30] ifFalse:[0 at 0]).
+ self keyboardFocus printString displayAt: (0 at ofs)+(0 at 45).
+ ].
+ "Notify listeners"
+ self sendListenEvent: evt to: self eventListeners.
+
+ evt isWindowEvent ifTrue: [
+ self sendEvent: evt focus: nil.
+ ^self mouseOverHandler processMouseOver: lastMouseEvent].
+
+ evt isKeyboard ifTrue:[
+ self sendListenEvent: evt to: self keyboardListeners.
+ self sendKeyboardEvent: evt.
+ ^self mouseOverHandler processMouseOver: lastMouseEvent].
+
+ evt isDropEvent ifTrue:[
+ self sendEvent: evt focus: nil.
+ ^self mouseOverHandler processMouseOver: lastMouseEvent].
+
+ evt isMouse ifTrue:[
+ self sendListenEvent: evt to: self mouseListeners.
+ lastMouseEvent := evt].
+
+ "Check for pending drag or double click operations."
+ mouseClickState ifNotNil:[
+ (mouseClickState handleEvent: evt from: self) ifFalse:[
+ "Possibly dispatched #click: or something and will not re-establish otherwise"
+ ^self mouseOverHandler processMouseOver: lastMouseEvent]].
+
+ evt isMove ifTrue:[
+ self position: evt position.
+ self sendMouseEvent: evt.
+ ] ifFalse:[
+ "Issue a synthetic move event if we're not at the position of the event"
+ (evt position = self position) ifFalse:[self moveToEvent: evt].
+ "Drop submorphs on button events"
+ (self hasSubmorphs)
+ ifTrue:[self dropMorphs: evt]
+ ifFalse:[self sendMouseEvent: evt].
+ ].
+ ShowEvents == true ifTrue:[self mouseFocus printString displayAt: (0 at ofs) + (0 at 15)].
+ self mouseOverHandler processMouseOver: lastMouseEvent.
+ "self handleDragOutside: anEvent."
+ !
Item was added:
+ ----- Method: HandMorph>>hasChanged (in category 'drawing') -----
+ hasChanged
+ "Return true if this hand has changed, either because it has moved or because some morph it is holding has changed."
+
+ ^ hasChanged ifNil: [ true ]
+ !
Item was added:
+ ----- Method: HandMorph>>hasUserInformation (in category 'drawing') -----
+ hasUserInformation
+ ^self userInitials notEmpty or: [self userPicture notNil]!
Item was added:
+ ----- Method: HandMorph>>initForEvents (in category 'initialization') -----
+ initForEvents
+ mouseOverHandler := nil.
+ lastMouseEvent := MouseEvent new setType: #mouseMove position: 0 at 0 buttons: 0 hand: self.
+ lastEventBuffer := {1. 0. 0. 0. 0. 0. nil. nil}.
+ self resetClickState.!
Item was added:
+ ----- Method: HandMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ self initForEvents.
+ keyboardFocus := nil.
+ mouseFocus := nil.
+ bounds := 0 at 0 extent: Cursor normal extent.
+ userInitials := ''.
+ damageRecorder := DamageRecorder new.
+ cachedCanvasHasHoles := false.
+ temporaryCursor := temporaryCursorOffset := nil.
+ self initForEvents.!
Item was added:
+ ----- Method: HandMorph>>interrupted (in category 'initialization') -----
+ interrupted
+ "Something went wrong - we're about to bring up a debugger.
+ Release some stuff that could be problematic."
+ self releaseAllFoci. "or else debugger might not handle clicks"
+ !
Item was added:
+ ----- Method: HandMorph>>invalidRect:from: (in category 'change reporting') -----
+ invalidRect: damageRect from: aMorph
+ "Note that a change has occurred and record the given damage rectangle relative to the origin this hand's cache."
+ hasChanged := true.
+ aMorph == self ifTrue:[^self].
+ damageRecorder recordInvalidRect: damageRect.
+ !
Item was added:
+ ----- Method: HandMorph>>isCapturingGesturePoints (in category 'events-processing') -----
+ isCapturingGesturePoints
+ ^false!
Item was added:
+ ----- Method: HandMorph>>isGenieAvailable (in category 'genie-stubs') -----
+ isGenieAvailable
+ "Answer whether the Genie gesture recognizer is available for this hand"
+ ^false!
Item was added:
+ ----- Method: HandMorph>>isGenieEnabled (in category 'genie-stubs') -----
+ isGenieEnabled
+ "Answer whether the Genie gesture recognizer is enabled for this hand"
+ ^false!
Item was added:
+ ----- Method: HandMorph>>isGenieFocused (in category 'genie-stubs') -----
+ isGenieFocused
+ "Answer whether the Genie gesture recognizer is auto-focused for this hand"
+ ^false!
Item was added:
+ ----- Method: HandMorph>>isHandMorph (in category 'classification') -----
+ isHandMorph
+
+ ^ true!
Item was added:
+ ----- Method: HandMorph>>keyboardFocus (in category 'focus handling') -----
+ keyboardFocus
+ ^ keyboardFocus!
Item was added:
+ ----- Method: HandMorph>>keyboardFocus: (in category 'focus handling') -----
+ keyboardFocus: aMorphOrNil
+ keyboardFocus := aMorphOrNil!
Item was added:
+ ----- Method: HandMorph>>keyboardInterpreter (in category 'multilingual') -----
+ keyboardInterpreter
+
+ ^keyboardInterpreter ifNil: [keyboardInterpreter := LanguageEnvironment currentPlatform class defaultInputInterpreter]!
Item was added:
+ ----- Method: HandMorph>>keyboardListeners (in category 'listeners') -----
+ keyboardListeners
+ ^keyboardListeners!
Item was added:
+ ----- Method: HandMorph>>keyboardListeners: (in category 'listeners') -----
+ keyboardListeners: anArrayOrNil
+ keyboardListeners := anArrayOrNil!
Item was added:
+ ----- Method: HandMorph>>lastEvent (in category 'accessing') -----
+ lastEvent
+ ^ lastMouseEvent!
Item was added:
+ ----- Method: HandMorph>>mouseFocus (in category 'focus handling') -----
+ mouseFocus
+ ^mouseFocus!
Item was added:
+ ----- Method: HandMorph>>mouseFocus: (in category 'focus handling') -----
+ mouseFocus: aMorphOrNil
+ mouseFocus := aMorphOrNil!
Item was added:
+ ----- Method: HandMorph>>mouseListeners (in category 'listeners') -----
+ mouseListeners
+ ^mouseListeners!
Item was added:
+ ----- Method: HandMorph>>mouseListeners: (in category 'listeners') -----
+ mouseListeners: anArrayOrNil
+ mouseListeners := anArrayOrNil!
Item was added:
+ ----- Method: HandMorph>>mouseOverHandler (in category 'accessing') -----
+ mouseOverHandler
+ ^mouseOverHandler ifNil:[mouseOverHandler := MouseOverHandler new].!
Item was added:
+ ----- Method: HandMorph>>mouseTrailFrom: (in category 'private events') -----
+ mouseTrailFrom: currentBuf
+ "Current event, a mouse event buffer, is about to be processed. If there are other similar mouse events queued up, then drop them from the queue, and report the positions inbetween."
+
+ | nextEvent trail |
+ trail := WriteStream on: (Array new: 1).
+ trail nextPut: currentBuf third @ currentBuf fourth.
+ [(nextEvent := Sensor peekEvent) isNil] whileFalse:
+ [nextEvent first = currentBuf first
+ ifFalse: [^trail contents "different event type"].
+ nextEvent fifth = currentBuf fifth
+ ifFalse: [^trail contents "buttons changed"].
+ nextEvent sixth = currentBuf sixth
+ ifFalse: [^trail contents "modifiers changed"].
+ "nextEvent is similar. Remove it from the queue, and check the next."
+ nextEvent := Sensor nextEvent.
+ trail nextPut: nextEvent third @ nextEvent fourth].
+ ^trail contents!
Item was added:
+ ----- Method: HandMorph>>moveToEvent: (in category 'private events') -----
+ moveToEvent: anEvent
+ "Issue a mouse move event to make the receiver appear at the given position"
+ self handleEvent: (MouseMoveEvent new
+ setType: #mouseMove
+ startPoint: self position
+ endPoint: anEvent position
+ trail: (Array with: self position with: anEvent position)
+ buttons: anEvent buttons
+ hand: self
+ stamp: anEvent timeStamp)!
Item was added:
+ ----- Method: HandMorph>>needsToBeDrawn (in category 'drawing') -----
+ needsToBeDrawn
+ "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden."
+ "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor and shadow from the display."
+ (savedPatch notNil
+ or: [ (submorphs anySatisfy: [ :ea | ea visible ])
+ or: [ (temporaryCursor notNil and: [hardwareCursor isNil])
+ or: [ self hasUserInformation ]]])
+ ifTrue: [
+ "using the software cursor; hide the hardware one"
+ self showHardwareCursor: false.
+ ^ true].
+ ^ false
+ !
Item was added:
+ ----- Method: HandMorph>>newKeyboardFocus: (in category 'focus handling') -----
+ newKeyboardFocus: aMorphOrNil
+ "Make the given morph the new keyboard focus, canceling the previous keyboard focus if any. If the argument is nil, the current keyboard focus is cancelled."
+
+ | oldFocus newFocus |
+ oldFocus := self keyboardFocus.
+ newFocus := aMorphOrNil ifNotNil: [:m | m keyboardFocusDelegate].
+
+ self keyboardFocus: newFocus.
+
+ oldFocus == newFocus ifFalse: [
+ oldFocus ifNotNil: [:m | m keyboardFocusChange: false].
+ newFocus ifNotNil: [:m | m keyboardFocusChange: true]].
+
+ newFocus ifNotNil: [:m |
+ self compositionWindowManager keyboardFocusForAMorph: m].
+
+ ^ newFocus
+ !
Item was added:
+ ----- Method: HandMorph>>newMouseFocus: (in category 'focus handling') -----
+ newMouseFocus: aMorphOrNil
+ "Make the given morph the new mouse focus, canceling the previous mouse focus if any. If the argument is nil, the current mouse focus is cancelled."
+ self mouseFocus: aMorphOrNil.
+ !
Item was added:
+ ----- Method: HandMorph>>newMouseFocus:event: (in category 'focus handling') -----
+ newMouseFocus: aMorph event: event
+ aMorph isNil
+ ifFalse: [targetOffset := event cursorPoint - aMorph position].
+ ^self newMouseFocus: aMorph!
Item was added:
+ ----- Method: HandMorph>>noButtonPressed (in category 'accessing') -----
+ noButtonPressed
+ "Answer whether any mouse button is not being pressed."
+
+ ^self anyButtonPressed not!
Item was added:
+ ----- Method: HandMorph>>nonCachingFullDrawOn: (in category 'drawing') -----
+ nonCachingFullDrawOn: aCanvas
+
+ "A HandMorph has unusual drawing requirements:
+ 1. the hand itself (i.e., the cursor) appears in front of its submorphs
+ 2. morphs being held by the hand cast a shadow on the world/morphs below
+ The illusion is that the hand plucks up morphs and carries them above the world."
+ "Note: This version does not cache an image of the morphs being held by the hand.
+ Thus, it is slower for complex morphs, but consumes less space."
+
+ submorphs isEmpty ifTrue: [^ self drawOn: aCanvas]. "just draw the hand itself"
+ aCanvas asShadowDrawingCanvas
+ translateBy: self shadowOffset during:[:shadowCanvas| | shadowForm |
+ "Note: We use a shadow form here to prevent drawing
+ overlapping morphs multiple times using the transparent
+ shadow color."
+ shadowForm := self shadowForm.
+ "
+ shadowForm displayAt: shadowForm offset negated. Display forceToScreen: (0 at 0 extent: shadowForm extent).
+ "
+ shadowCanvas paintImage: shadowForm at: shadowForm offset. "draw shadows"
+ ].
+ "draw morphs in front of shadows"
+ self drawSubmorphsOn: aCanvas.
+ self drawOn: aCanvas. "draw the hand itself in front of morphs"
+ !
Item was added:
+ ----- Method: HandMorph>>noticeMouseOver:event: (in category 'event handling') -----
+ noticeMouseOver: aMorph event: anEvent
+ mouseOverHandler ifNil:[^self].
+ mouseOverHandler noticeMouseOver: aMorph event: anEvent.!
Item was added:
+ ----- Method: HandMorph>>objectForDataStream: (in category 'objects from disk') -----
+ objectForDataStream: refStrm
+ | dp |
+ "I am about to be written on an object file. Write a path to me in the other system instead."
+
+ (refStrm project world hands includes: self) ifTrue: [
+ ^ self]. "owned by the project"
+ dp := DiskProxy global: #World selector: #primaryHand args: #().
+ refStrm replace: self with: dp.
+ ^ dp
+ "Note, when this file is loaded in an MVC project, this will return nil. The MenuItemMorph that has this in a field will have that item not work. Maybe warn the user at load time?"!
Item was added:
+ ----- Method: HandMorph>>objectToPaste (in category 'paste buffer') -----
+ objectToPaste
+ "It may need to be sent #startRunning by the client"
+ ^ Cursor wait showWhile: [PasteBuffer veryDeepCopy]
+
+ "PasteBuffer usableDuplicateIn: self world"
+ !
Item was added:
+ ----- Method: HandMorph>>obtainHalo: (in category 'halo handling') -----
+ obtainHalo: aHalo
+ "Used for transfering halos between hands"
+ | formerOwner |
+ self halo == aHalo ifTrue:[^self].
+ "Find former owner"
+ formerOwner := self world hands detect:[:h| h halo == aHalo] ifNone:[nil].
+ formerOwner ifNotNil:[formerOwner releaseHalo: aHalo].
+ self halo: aHalo!
Item was added:
+ ----- Method: HandMorph>>pasteBuffer (in category 'paste buffer') -----
+ pasteBuffer
+ "Return the paste buffer associated with this hand"
+ ^ PasteBuffer!
Item was added:
+ ----- Method: HandMorph>>pasteBuffer: (in category 'paste buffer') -----
+ pasteBuffer: aMorphOrNil
+ "Set the contents of the paste buffer."
+ PasteBuffer := aMorphOrNil.
+
+ !
Item was added:
+ ----- Method: HandMorph>>pasteMorph (in category 'paste buffer') -----
+ pasteMorph
+
+ | aPastee |
+ PasteBuffer ifNil: [^ self inform: 'Nothing to paste.' translated].
+ self attachMorph: (aPastee := self objectToPaste).
+ aPastee align: aPastee center with: self position.
+ aPastee player ifNotNil: [aPastee player startRunning]
+ !
Item was added:
+ ----- Method: HandMorph>>position (in category 'geometry') -----
+ position
+
+ ^temporaryCursor
+ ifNil: [bounds topLeft]
+ ifNotNil: [bounds topLeft - temporaryCursorOffset]!
Item was added:
+ ----- Method: HandMorph>>position: (in category 'geometry') -----
+ position: aPoint
+ "Overridden to align submorph origins to the grid if gridding is on."
+ | adjustedPosition delta box |
+ adjustedPosition := aPoint.
+ temporaryCursor ifNotNil: [adjustedPosition := adjustedPosition + temporaryCursorOffset].
+
+ "Copied from Morph to avoid owner layoutChanged"
+ "Change the position of this morph and and all of its submorphs."
+ delta := adjustedPosition - bounds topLeft.
+ delta isZero ifTrue: [^ self]. "Null change"
+ box := self fullBounds.
+ (delta dotProduct: delta) > 100 ifTrue:[
+ "e.g., more than 10 pixels moved"
+ self invalidRect: box.
+ self invalidRect: (box translateBy: delta).
+ ] ifFalse:[
+ self invalidRect: (box merge: (box translateBy: delta)).
+ ].
+ self privateFullMoveBy: delta.
+ !
Item was added:
+ ----- Method: HandMorph>>processEvents (in category 'event handling') -----
+ processEvents
+ "Process user input events from the local input devices."
+
+ | evt evtBuf type hadAny |
+ ActiveEvent ifNotNil:
+ ["Meaning that we were invoked from within an event response.
+ Make sure z-order is up to date"
+
+ self mouseOverHandler processMouseOver: lastMouseEvent].
+ hadAny := false.
+ [(evtBuf := Sensor nextEvent) isNil] whileFalse:
+ [evt := nil. "for unknown event types"
+ type := evtBuf first.
+ type = EventTypeMouse ifTrue: [evt := self generateMouseEvent: evtBuf].
+ type = EventTypeKeyboard
+ ifTrue: [evt := self generateKeyboardEvent: evtBuf].
+ type = EventTypeDragDropFiles
+ ifTrue: [evt := self generateDropFilesEvent: evtBuf].
+ type = EventTypeWindow
+ ifTrue:[evt := self generateWindowEvent: evtBuf].
+ "All other events are ignored"
+ (type ~= EventTypeDragDropFiles and: [evt isNil]) ifTrue: [^self].
+ evt isNil
+ ifFalse:
+ ["Finally, handle it"
+
+ self handleEvent: evt.
+ hadAny := true.
+
+ "For better user feedback, return immediately after a mouse event has been processed."
+ evt isMouse ifTrue: [^self]]].
+ "note: if we come here we didn't have any mouse events"
+ mouseClickState notNil
+ ifTrue:
+ ["No mouse events during this cycle. Make sure click states time out accordingly"
+
+ mouseClickState handleEvent: lastMouseEvent asMouseMove from: self].
+ hadAny
+ ifFalse:
+ ["No pending events. Make sure z-order is up to date"
+
+ self mouseOverHandler processMouseOver: lastMouseEvent]!
Item was added:
+ ----- Method: HandMorph>>releaseAllFoci (in category 'focus handling') -----
+ releaseAllFoci
+ mouseFocus := nil.
+ keyboardFocus := nil.
+ !
Item was added:
+ ----- Method: HandMorph>>releaseCachedState (in category 'caching') -----
+ releaseCachedState
+ | oo ui |
+ ui := userInitials.
+ super releaseCachedState.
+ cacheCanvas := nil.
+ oo := owner.
+ self removeAllMorphs.
+ self initialize. "nuke everything"
+ self privateOwner: oo.
+ self releaseAllFoci.
+ self userInitials: ui andPicture: (self userPicture).!
Item was added:
+ ----- Method: HandMorph>>releaseHalo: (in category 'halo handling') -----
+ releaseHalo: aHalo
+ "Used for transfering halos between hands"
+ self removeProperty: #halo!
Item was added:
+ ----- Method: HandMorph>>releaseKeyboardFocus (in category 'focus handling') -----
+ releaseKeyboardFocus
+ "Release the current keyboard focus unconditionally"
+ self newKeyboardFocus: nil.
+ !
Item was added:
+ ----- Method: HandMorph>>releaseKeyboardFocus: (in category 'focus handling') -----
+ releaseKeyboardFocus: aMorph
+ "If the given morph had the keyboard focus before, release it"
+ self keyboardFocus == aMorph ifTrue:[self releaseKeyboardFocus].!
Item was added:
+ ----- Method: HandMorph>>releaseMouseFocus (in category 'focus handling') -----
+ releaseMouseFocus
+ "Release the current mouse focus unconditionally."
+ self newMouseFocus: nil.!
Item was added:
+ ----- Method: HandMorph>>releaseMouseFocus: (in category 'focus handling') -----
+ releaseMouseFocus: aMorph
+ "If the given morph had the mouse focus before, release it"
+ self mouseFocus == aMorph ifTrue:[self releaseMouseFocus].!
Item was added:
+ ----- Method: HandMorph>>removeEventListener: (in category 'listeners') -----
+ removeEventListener: anObject
+ "Remove anObject from the current event listeners."
+ self eventListeners: (self removeListener: anObject from: self eventListeners).!
Item was added:
+ ----- Method: HandMorph>>removeHalo (in category 'halo handling') -----
+ removeHalo
+ "remove the receiver's halo (if any)"
+ | halo |
+ halo := self halo.
+ halo
+ ifNil: [^ self].
+ halo delete.
+ self removeProperty: #halo!
Item was added:
+ ----- Method: HandMorph>>removeHaloFromClick:on: (in category 'halo handling') -----
+ removeHaloFromClick: anEvent on: aMorph
+ | halo |
+ halo := self halo
+ ifNil: [^ self].
+ (halo target hasOwner: self)
+ ifTrue: [^ self].
+ (halo staysUpWhenMouseIsDownIn: aMorph)
+ ifFalse: [self removeHalo]!
Item was added:
+ ----- Method: HandMorph>>removeKeyboardListener: (in category 'listeners') -----
+ removeKeyboardListener: anObject
+ "Remove anObject from the current keyboard listeners."
+ self keyboardListeners: (self removeListener: anObject from: self keyboardListeners).!
Item was added:
+ ----- Method: HandMorph>>removeListener:from: (in category 'listeners') -----
+ removeListener: anObject from: aListenerGroup
+ "Remove anObject from the given listener group. Return the new group."
+
+ | listeners |
+ aListenerGroup ifNil: [^nil].
+ listeners := aListenerGroup.
+ listeners := listeners copyWithout: anObject.
+ listeners := listeners copyWithout: nil. "obsolete entries"
+ listeners isEmpty ifTrue: [listeners := nil].
+ ^listeners!
Item was added:
+ ----- Method: HandMorph>>removeMouseListener: (in category 'listeners') -----
+ removeMouseListener: anObject
+ "Remove anObject from the current mouse listeners."
+ self mouseListeners: (self removeListener: anObject from: self mouseListeners).!
Item was added:
+ ----- Method: HandMorph>>removePendingBalloonFor: (in category 'balloon help') -----
+ removePendingBalloonFor: aMorph
+ "Get rid of pending balloon help."
+ self removeAlarm: #spawnBalloonFor:.
+ self deleteBalloonTarget: aMorph.!
Item was added:
+ ----- Method: HandMorph>>removePendingHaloFor: (in category 'halo handling') -----
+ removePendingHaloFor: aMorph
+ "Get rid of pending balloon help or halo actions."
+ self removeAlarm: #spawnMagicHaloFor:.!
Item was added:
+ ----- Method: HandMorph>>resetClickState (in category 'double click support') -----
+ resetClickState
+ "Reset the double-click detection state to normal (i.e., not waiting for a double-click)."
+ mouseClickState := nil.!
Item was added:
+ ----- Method: HandMorph>>resourceJustLoaded (in category 'initialization') -----
+ resourceJustLoaded
+ "In case resource relates to me"
+ cacheCanvas := nil.!
Item was added:
+ ----- Method: HandMorph>>restoreSavedPatchOn: (in category 'drawing') -----
+ restoreSavedPatchOn: aCanvas
+ "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor."
+
+ hasChanged := false.
+ savedPatch ifNotNil:
+ [aCanvas drawImage: savedPatch at: savedPatch offset.
+ self hasUserInformation ifTrue: [^self]. "cannot use hw cursor if so"
+ submorphs notEmpty ifTrue: [^self].
+ (temporaryCursor notNil and: [hardwareCursor isNil]) ifTrue: [^self].
+
+ "Make the transition to using hardware cursor. Clear savedPatch and
+ report one final damage rectangle to erase the image of the software cursor."
+ super invalidRect: (savedPatch offset
+ extent: savedPatch extent + self shadowOffset)
+ from: self.
+ self showHardwareCursor: true.
+ savedPatch := nil]!
Item was added:
+ ----- Method: HandMorph>>savePatchFrom: (in category 'drawing') -----
+ savePatchFrom: aCanvas
+ "Save the part of the given canvas under this hand as a Form and return its bounding rectangle."
+
+ "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management."
+
+ | damageRect myBnds |
+ damageRect := myBnds := self fullBounds.
+ savedPatch ifNotNil:
+ [damageRect := myBnds merge: (savedPatch offset extent: savedPatch extent)].
+ (savedPatch isNil or: [savedPatch extent ~= myBnds extent])
+ ifTrue:
+ ["allocate new patch form if needed"
+
+ savedPatch := aCanvas form allocateForm: myBnds extent].
+ aCanvas contentsOfArea: (myBnds translateBy: aCanvas origin)
+ into: savedPatch.
+ savedPatch offset: myBnds topLeft.
+ ^damageRect!
Item was added:
+ ----- Method: HandMorph>>selectedObject (in category 'selected object') -----
+ selectedObject
+ "answer the selected object for the hand or nil is none"
+ | halo |
+ halo := self halo.
+ halo isNil
+ ifTrue: [^ nil].
+ ^ halo target renderedMorph!
Item was added:
+ ----- Method: HandMorph>>sendEvent:focus: (in category 'private events') -----
+ sendEvent: anEvent focus: focusHolder
+ "Send the event to the morph currently holding the focus, or if none to the owner of the hand."
+ ^self sendEvent: anEvent focus: focusHolder clear:[nil]!
Item was added:
+ ----- Method: HandMorph>>sendEvent:focus:clear: (in category 'private events') -----
+ sendEvent: anEvent focus: focusHolder clear: aBlock
+ "Send the event to the morph currently holding the focus, or if none to the owner of the hand."
+ | result |
+ focusHolder ifNotNil:[^self sendFocusEvent: anEvent to: focusHolder clear: aBlock].
+ ActiveEvent := anEvent.
+ result := owner processEvent: anEvent.
+ ActiveEvent := nil.
+ ^result!
Item was added:
+ ----- Method: HandMorph>>sendFocusEvent:to:clear: (in category 'private events') -----
+ sendFocusEvent: anEvent to: focusHolder clear: aBlock
+ "Send the event to the morph currently holding the focus"
+ | result w |
+ w := focusHolder world ifNil:[^ aBlock value].
+ w becomeActiveDuring:[
+ ActiveHand := self.
+ ActiveEvent := anEvent.
+ result := focusHolder handleFocusEvent:
+ (anEvent transformedBy: (focusHolder transformedFrom: self)).
+ ].
+ ^result!
Item was added:
+ ----- Method: HandMorph>>sendKeyboardEvent: (in category 'private events') -----
+ sendKeyboardEvent: anEvent
+ "Send the event to the morph currently holding the focus, or if none to
+ the owner of the hand."
+ ^ self
+ sendEvent: anEvent
+ focus: self keyboardFocus
+ clear: [self keyboardFocus: nil]!
Item was added:
+ ----- Method: HandMorph>>sendListenEvent:to: (in category 'private events') -----
+ sendListenEvent: anEvent to: listenerGroup
+ "Send the event to the given group of listeners"
+ listenerGroup ifNil:[^self].
+ listenerGroup do:[:listener|
+ listener ifNotNil:[listener handleListenEvent: anEvent copy]].!
Item was added:
+ ----- Method: HandMorph>>sendMouseEvent: (in category 'private events') -----
+ sendMouseEvent: anEvent
+ "Send the event to the morph currently holding the focus, or if none to the owner of the hand."
+ ^self sendEvent: anEvent focus: self mouseFocus clear:[self mouseFocus: nil]!
Item was added:
+ ----- Method: HandMorph>>shadowForm (in category 'drawing') -----
+ shadowForm
+ "Return a 1-bit shadow of my submorphs. Assumes submorphs is not empty"
+ | bnds canvas |
+ bnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]).
+ canvas := (Display defaultCanvasClass extent: bnds extent depth: 1)
+ asShadowDrawingCanvas: Color black.
+ canvas translateBy: bnds topLeft negated
+ during:[:tempCanvas| self drawSubmorphsOn: tempCanvas].
+ ^ canvas form offset: bnds topLeft!
Item was added:
+ ----- Method: HandMorph>>shadowOffset (in category 'drop shadows') -----
+ shadowOffset
+
+ ^ 6 at 8!
Item was added:
+ ----- Method: HandMorph>>showHardwareCursor: (in category 'drawing') -----
+ showHardwareCursor: aBool
+ "Show/hide the current hardware cursor as indicated."
+ | cursor |
+ cursor := hardwareCursor ifNil:[aBool ifTrue:[Cursor normal] ifFalse:[Cursor blank]].
+ Cursor currentCursor == cursor ifFalse: [cursor show].
+ !
Item was added:
+ ----- Method: HandMorph>>showTemporaryCursor: (in category 'cursor') -----
+ showTemporaryCursor: cursorOrNil
+ "Set the temporary cursor to the given Form. If the argument is nil, revert to the normal cursor."
+
+ self showTemporaryCursor: cursorOrNil hotSpotOffset: 0 at 0
+ !
Item was added:
+ ----- Method: HandMorph>>showTemporaryCursor:hotSpotOffset: (in category 'cursor') -----
+ showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset
+ "Set the temporary cursor to the given Form.
+ If the argument is nil, revert to the normal hardware cursor."
+
+ self changed.
+ temporaryCursorOffset
+ ifNotNil: [bounds := bounds translateBy: temporaryCursorOffset negated].
+ cursorOrNil isNil
+ ifTrue: [temporaryCursor := temporaryCursorOffset := hardwareCursor := nil]
+ ifFalse:
+ [temporaryCursor := cursorOrNil asCursorForm.
+ temporaryCursorOffset := temporaryCursor offset - hotSpotOffset.
+ (cursorOrNil isKindOf: Cursor) ifTrue: [hardwareCursor := cursorOrNil]].
+ bounds := self cursorBounds.
+ self
+ userInitials: userInitials andPicture: self userPicture;
+ layoutChanged;
+ changed;
+ showHardwareCursor: (temporaryCursor isNil).!
Item was added:
+ ----- Method: HandMorph>>spawnBalloonFor: (in category 'balloon help') -----
+ spawnBalloonFor: aMorph
+
+ aMorph wantsBalloon ifFalse: [^ self].
+ aMorph showBalloon: aMorph balloonText hand: self.!
Item was added:
+ ----- Method: HandMorph>>spawnMagicHaloFor: (in category 'halo handling') -----
+ spawnMagicHaloFor: aMorph
+ (self halo notNil and:[self halo target == aMorph]) ifTrue:[^self].
+ aMorph addMagicHaloFor: self.!
Item was added:
+ ----- Method: HandMorph>>targetOffset (in category 'accessing') -----
+ targetOffset
+ "Return the offset of the last mouseDown location relative to the origin of the recipient morph. During menu interactions, this is the absolute location of the mouse down event that invoked the menu."
+
+ ^ targetOffset
+ !
Item was added:
+ ----- Method: HandMorph>>targetOffset: (in category 'grabbing/dropping') -----
+ targetOffset: offsetPoint
+ "Set the offset at which we clicked down in the target morph"
+
+ targetOffset := offsetPoint!
Item was added:
+ ----- Method: HandMorph>>targetPoint (in category 'accessing') -----
+ targetPoint
+ "Return the new position of the target.
+ I.E. return the position of the hand less
+ the original distance between hand and target position"
+
+ ^ self position - targetOffset
+ !
Item was added:
+ ----- Method: HandMorph>>temporaryCursor (in category 'cursor') -----
+ temporaryCursor
+ ^ temporaryCursor!
Item was added:
+ ----- Method: HandMorph>>triggerBalloonFor:after: (in category 'balloon help') -----
+ triggerBalloonFor: aMorph after: timeOut
+ "Trigger balloon help after the given time out for some morph"
+ self addAlarm: #spawnBalloonFor: with: aMorph after: timeOut.!
Item was added:
+ ----- Method: HandMorph>>triggerHaloFor:after: (in category 'halo handling') -----
+ triggerHaloFor: aMorph after: timeOut
+ "Trigger automatic halo after the given time out for some morph"
+ self addAlarm: #spawnMagicHaloFor: with: aMorph after: timeOut!
Item was added:
+ ----- Method: HandMorph>>updateCacheCanvas: (in category 'drawing') -----
+ updateCacheCanvas: aCanvas
+ "Update the cached image of the morphs being held by this hand."
+
+ "Note: The following is an attempt to quickly get out if there's no change"
+
+ | subBnds rectList nPix |
+ subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]).
+ rectList := damageRecorder invalidRectsFullBounds: subBnds.
+ damageRecorder reset.
+ (rectList isEmpty
+ and: [cacheCanvas notNil and: [cacheCanvas extent = subBnds extent]])
+ ifTrue: [^self].
+
+ "Always check for real translucency -- can't be cached in a form"
+ self submorphsDo:
+ [:m |
+ m wantsToBeCachedByHand
+ ifFalse:
+ [cacheCanvas := nil.
+ cachedCanvasHasHoles := true.
+ ^self]].
+ (cacheCanvas isNil or: [cacheCanvas extent ~= subBnds extent])
+ ifTrue:
+ [cacheCanvas := (aCanvas allocateForm: subBnds extent) getCanvas.
+ cacheCanvas translateBy: subBnds origin negated
+ during: [:tempCanvas | self drawSubmorphsOn: tempCanvas].
+ self submorphsDo:
+ [:m |
+ (m areasRemainingToFill: subBnds) isEmpty
+ ifTrue: [^cachedCanvasHasHoles := false]].
+ nPix := cacheCanvas form tallyPixelValues first.
+ "--> begin rounded corners hack <---"
+ cachedCanvasHasHoles := (nPix = 48
+ and: [submorphs size = 1 and: [submorphs first wantsRoundedCorners]])
+ ifTrue: [false]
+ ifFalse: [nPix > 0].
+ "--> end rounded corners hack <---"
+ ^self].
+
+ "incrementally update the cache canvas"
+ cacheCanvas translateBy: subBnds origin negated
+ during:
+ [:cc |
+ rectList do:
+ [:r |
+ cc clipBy: r
+ during:
+ [:c |
+ c fillColor: Color transparent.
+ self drawSubmorphsOn: c]]]!
Item was added:
+ ----- Method: HandMorph>>userInitials (in category 'accessing') -----
+ userInitials
+
+ ^ userInitials!
Item was added:
+ ----- Method: HandMorph>>userInitials:andPicture: (in category 'geometry') -----
+ userInitials: aString andPicture: aForm
+
+ | cb pictRect initRect f |
+
+ userInitials := aString.
+ pictRect := initRect := cb := self cursorBounds.
+ userInitials isEmpty ifFalse: [
+ f := TextStyle defaultFont.
+ initRect := cb topRight + (0 at 4) extent: (f widthOfString: userInitials)@(f height).
+ ].
+ self userPicture: aForm.
+ aForm ifNotNil: [
+ pictRect := (self cursorBounds topRight + (0 at 24)) extent: aForm extent.
+ ].
+ self bounds: ((cb merge: initRect) merge: pictRect).
+
+
+ !
Item was added:
+ ----- Method: HandMorph>>userPicture (in category 'accessing') -----
+ userPicture
+ ^self valueOfProperty: #remoteUserPicture
+
+ !
Item was added:
+ ----- Method: HandMorph>>userPicture: (in category 'accessing') -----
+ userPicture: aFormOrNil
+ ^self setProperty: #remoteUserPicture toValue: aFormOrNil
+ !
Item was added:
+ ----- Method: HandMorph>>veryDeepCopyWith: (in category 'copying') -----
+ veryDeepCopyWith: deepCopier
+ "Return self. Do not copy hands this way."
+ ^ self!
Item was added:
+ ----- Method: HandMorph>>visible: (in category 'drawing') -----
+ visible: aBoolean
+ self needsToBeDrawn ifFalse: [ ^self ].
+ super visible: aBoolean!
Item was added:
+ ----- Method: HandMorph>>waitForClicksOrDrag:event: (in category 'double click support') -----
+ waitForClicksOrDrag: aMorph event: evt
+ "Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks.
+ This message is typically sent to the Hand by aMorph when it first receives a mouse-down event.
+ The callback methods invoked on aMorph (which are passed a copy of evt) are:
+ #click: sent when the mouse button goes up within doubleClickTime.
+ #doubleClick: sent when the mouse goes up, down, and up again all within DoubleClickTime.
+ #doubleClickTimeout: sent when the mouse does not have a doubleClick within DoubleClickTime.
+ #startDrag: sent when the mouse moves more than 10 pixels from evt's position within DoubleClickTime.
+ Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus,
+ which is typically done by aMorph in its click:, doubleClick:, or drag: methods."
+
+ ^self waitForClicksOrDrag: aMorph event: evt selectors: #( #click: #doubleClick: #doubleClickTimeout: #startDrag:) threshold: HandMorph dragThreshold!
Item was added:
+ ----- Method: HandMorph>>waitForClicksOrDrag:event:selectors:threshold: (in category 'double click support') -----
+ waitForClicksOrDrag: aMorph event: evt selectors: clickAndDragSelectors threshold: threshold
+
+ "Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks.
+ This message is typically sent to the Hand by aMorph when it first receives a mouse-down event.
+ The callback methods, named in clickAndDragSelectors and passed a copy of evt, are:
+ 1 (click) sent when the mouse button goes up within doubleClickTime.
+ 2 (doubleClick) sent when the mouse goes up, down, and up again all within DoubleClickTime.
+ 3 (doubleClickTimeout) sent when the mouse does not have a doubleClick within DoubleClickTime.
+ 4 (startDrag) sent when the mouse moves more than threshold pixels from evt's position within DoubleClickTime.
+ Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus,
+ which is typically done by aMorph in its click:, doubleClick:, or drag: methods."
+
+ mouseClickState :=
+ MouseClickState new
+ client: aMorph
+ click: clickAndDragSelectors first
+ dblClick: clickAndDragSelectors second
+ dblClickTime: DoubleClickTime
+ dblClickTimeout: clickAndDragSelectors third
+ drag: clickAndDragSelectors fourth
+ threshold: threshold
+ event: evt.
+ !
Item was added:
+ EllipseMorph subclass: #HandleMorph
+ instanceVariableNames: 'pointBlock lastPointBlock'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !HandleMorph commentStamp: '<historical>' prior: 0!
+ A HandleMorph provides mouse-up control behavior.!
Item was added:
+ ----- Method: HandleMorph>>forEachPointDo: (in category 'initialize') -----
+ forEachPointDo: aBlock
+ pointBlock := aBlock!
Item was added:
+ ----- Method: HandleMorph>>forEachPointDo:lastPointDo: (in category 'initialize') -----
+ forEachPointDo: aBlock lastPointDo: otherBlock
+ pointBlock := aBlock.
+ lastPointBlock := otherBlock!
Item was added:
+ ----- Method: HandleMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self extent: 8 @ 8.
+ !
Item was added:
+ ----- Method: HandleMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: aMorph event: anEvent
+ "So that when the hand drops me (into the world) I go away"
+ self removeHalo.
+ lastPointBlock ifNotNil: [lastPointBlock value: self center].
+ self flag: #arNote. "Probably unnecessary"
+ anEvent hand releaseKeyboardFocus: self.
+ self changed.
+ self delete.
+ !
Item was added:
+ ----- Method: HandleMorph>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+ "Check for cursor keys"
+ | keyValue |
+ owner isHandMorph ifFalse:[^self].
+ keyValue := evt keyValue.
+ keyValue = 28 ifTrue:[^self position: self position - (1 at 0)].
+ keyValue = 29 ifTrue:[^self position: self position + (1 at 0)].
+ keyValue = 30 ifTrue:[^self position: self position - (0 at 1)].
+ keyValue = 31 ifTrue:[^self position: self position + (0 at 1)].
+ "Special case for return"
+ keyValue = 13 ifTrue:[
+ "Drop the receiver and be done"
+ self flag: #arNote. "Probably unnecessary"
+ owner releaseKeyboardFocus: self.
+ self delete].
+ !
Item was added:
+ ----- Method: HandleMorph>>startStepping (in category 'stepping and presenter') -----
+ startStepping
+ "Make the receiver the keyboard focus for editing"
+ super startStepping.
+ "owner isHandMorph ifTrue:[owner newKeyboardFocus: self]."
+ self flag: #arNote. "make me #handleKeyboard:"!
Item was added:
+ ----- Method: HandleMorph>>step (in category 'stepping and presenter') -----
+ step
+ pointBlock value: self center!
Item was added:
+ ----- Method: HandleMorph>>stepTime (in category 'testing') -----
+ stepTime
+ "Update every hundredth of a second."
+ ^ 10
+ !
Item was added:
+ ----- Method: HierarchyBrowser>>postAcceptBrowseFor: (in category '*morphic') -----
+ postAcceptBrowseFor: aHierarchyBrowser
+ (aHierarchyBrowser selectedClass ~= self selectedClass or: [ aHierarchyBrowser selectedMessageName notNil ]) ifTrue: [ self selectMessageCategoryNamed: nil ].
+ aHierarchyBrowser instanceMessagesIndicated
+ ifTrue: [ self indicateInstanceMessages ]
+ ifFalse: [ self indicateClassMessages ].
+ self
+ selectClass: aHierarchyBrowser selectedClass ;
+ selectedMessageName: aHierarchyBrowser selectedMessageName ;
+ showHomeCategory!
Item was added:
+ ----- Method: HierarchyBrowser>>representsSameBrowseeAs: (in category '*morphic') -----
+ representsSameBrowseeAs: anotherModel
+ ^ self hasUnacceptedEdits not
+ and: [ classDisplayList size = anotherModel classList size
+ and: [ classDisplayList includesAllOf: anotherModel classList ] ]!
Item was added:
+ SimpleButtonMorph subclass: #IconicButton
+ instanceVariableNames: 'darkenedForm'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !IconicButton commentStamp: '<historical>' prior: 0!
+ A "Simple Button" in which the appearance is provided by a Form.!
Item was added:
+ ----- Method: IconicButton>>addLabelItemsTo:hand: (in category 'menu') -----
+ addLabelItemsTo: aCustomMenu hand: aHandMorph
+ "don't do the inherited behavior, since there is no textual label in this case"!
Item was added:
+ ----- Method: IconicButton>>borderInset (in category 'accessing') -----
+ borderInset
+ self borderStyle: (BorderStyle inset width: 2).!
Item was added:
+ ----- Method: IconicButton>>borderNormal (in category 'initialization') -----
+ borderNormal
+ self borderStyle: (BorderStyle width: 2 color: Color transparent).!
Item was added:
+ ----- Method: IconicButton>>borderRaised (in category 'accessing') -----
+ borderRaised
+ self borderStyle: (BorderStyle raised width: 2).!
Item was added:
+ ----- Method: IconicButton>>borderThick (in category 'initialization') -----
+ borderThick
+ self borderStyle: (BorderStyle width: 2 color: self raisedColor twiceDarker).!
Item was added:
+ ----- Method: IconicButton>>buttonSetup (in category 'initialization') -----
+ buttonSetup
+ self actWhen: #buttonUp.
+ self cornerStyle: #rounded.
+ self borderNormal.
+ self on: #mouseEnter send: #borderRaised to: self.
+ self on: #mouseLeave send: #borderNormal to: self.
+ self on: #mouseLeaveDragging send: #borderNormal to: self.
+ self on: #mouseDown send: #borderInset to: self.
+ self on: #mouseUp send: #borderRaised to: self.!
Item was added:
+ ----- Method: IconicButton>>darken (in category 'as yet unclassified') -----
+ darken
+
+ self firstSubmorph form: self darkenedForm!
Item was added:
+ ----- Method: IconicButton>>darkenedForm (in category 'as yet unclassified') -----
+ darkenedForm
+ ^ darkenedForm ifNil: [ darkenedForm := self firstSubmorph baseGraphic darker ]!
Item was added:
+ ----- Method: IconicButton>>doButtonAction (in category 'button') -----
+ doButtonAction
+
+ super doButtonAction.
+ self restoreImage.!
Item was added:
+ ----- Method: IconicButton>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ self useSquareCorners!
Item was added:
+ ----- Method: IconicButton>>initializeWithThumbnail:withLabel:andColor:andSend:to: (in category 'initialization') -----
+ initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: aColor andSend: aSelector to: aReceiver
+ "Initialize the receiver to show aThumbnail on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the supplied selector to the supplied receiver"
+
+ | labeledItem nonTranslucent |
+ nonTranslucent := aColor asNontranslucentColor.
+ labeledItem := AlignmentMorph newColumn.
+ labeledItem color: nonTranslucent.
+ labeledItem borderWidth: 0.
+ labeledItem
+ layoutInset: 4 at 0;
+ cellPositioning: #center.
+ labeledItem addMorph: aThumbnail.
+ labeledItem addMorphBack: (Morph new extent: (4 at 4)) beTransparent.
+ labeledItem addMorphBack: (TextMorph new
+ backgroundColor: nonTranslucent;
+ contentsAsIs: aLabel;
+ beAllFont: Preferences standardEToysFont;
+ centered).
+
+ self
+ beTransparent;
+ labelGraphic: ((labeledItem imageForm: 32 backgroundColor: nonTranslucent forRectangle: labeledItem fullBounds) replaceColor: nonTranslucent withColor: Color transparent);
+ borderWidth: 0;
+ target: aReceiver;
+ actionSelector: #launchPartVia:label:;
+ arguments: {aSelector. aLabel};
+ actWhen: #buttonDown.
+
+ self stationarySetup.!
Item was added:
+ ----- Method: IconicButton>>initializeWithThumbnail:withLabel:andSend:to: (in category 'initialization') -----
+ initializeWithThumbnail: aThumbnail withLabel: aLabel andSend: aSelector to: aReceiver
+ "Initialize the receiver to show aThumbnail on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the supplied selector to the supplied receiver"
+
+ ^self initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: Color transparent andSend: aSelector to: aReceiver !
Item was added:
+ ----- Method: IconicButton>>labelFromString: (in category 'as yet unclassified') -----
+ labelFromString: aString
+ "Make an iconic label from aString"
+
+ self labelGraphic: (StringMorph contents: aString) imageForm
+ !
Item was added:
+ ----- Method: IconicButton>>labelGraphic: (in category 'as yet unclassified') -----
+ labelGraphic: aForm
+ | oldLabel graphicalMorph |
+ (oldLabel := self findA: SketchMorph)
+ ifNotNil: [oldLabel delete].
+ graphicalMorph := SketchMorph withForm: aForm.
+ self extent: graphicalMorph extent + (borderWidth + 6).
+ graphicalMorph position: self center - (graphicalMorph extent // 2).
+ self addMorph: graphicalMorph.
+ graphicalMorph
+ baseGraphic;
+ lock.
+ !
Item was added:
+ ----- Method: IconicButton>>mouseEnter: (in category 'events') -----
+ mouseEnter: evt
+
+ self borderStyle: BorderStyle thinGray!
Item was added:
+ ----- Method: IconicButton>>mouseLeave: (in category 'events') -----
+ mouseLeave: evt
+
+ self borderNormal!
Item was added:
+ ----- Method: IconicButton>>restoreImage (in category 'as yet unclassified') -----
+ restoreImage
+
+ self firstSubmorph restoreBaseGraphic.!
Item was added:
+ ----- Method: IconicButton>>setDefaultLabel (in category 'initialization') -----
+ setDefaultLabel
+ self labelGraphic: (ScriptingSystem formAtKey: 'squeakyMouse')!
Item was added:
+ ----- Method: IconicButton>>shedSelvedge (in category 'as yet unclassified') -----
+ shedSelvedge
+ self extent: (self extent - (6 at 6))!
Item was added:
+ ----- Method: IconicButton>>stationarySetup (in category 'initialization') -----
+ stationarySetup
+
+ self actWhen: #startDrag.
+ self cornerStyle: #rounded.
+ self borderNormal.
+ self on: #mouseEnter send: #borderThick to: self.
+ self on: #mouseDown send: nil to: nil.
+ self on: #mouseLeave send: #borderNormal to: self.
+ self on: #mouseLeaveDragging send: #borderNormal to: self.
+ self on: #mouseUp send: #borderThick to: self.!
Item was added:
+ Morph subclass: #ImageMorph
+ instanceVariableNames: 'image'
+ classVariableNames: 'DefaultForm'
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !ImageMorph commentStamp: 'efc 3/7/2003 17:48' prior: 0!
+ ImageMorph is a morph that displays a picture (Form). My extent is determined by the extent of my form.
+
+ Use #image: to set my picture.
+
+ Structure:
+ instance var Type Description
+ image Form The Form to use when drawing
+
+ Code examples:
+ ImageMorph new openInWorld; grabFromScreen
+
+ (Form fromFileNamed: 'myGraphicsFileName') asMorph openInWorld
+
+ Relationship to SketchMorph: ImageMorph should be favored over SketchMorph, a parallel, legacy class -- see the Swiki FAQ for details ( http://minnow.cc.gatech.edu/squeak/1372 ).
+ !
Item was added:
+ ----- Method: ImageMorph class>>authoringPrototype (in category 'scripting') -----
+ authoringPrototype
+ | aMorph aForm |
+ aMorph := super authoringPrototype.
+ aForm := ScriptingSystem formAtKey: 'Image'.
+ aForm ifNil: [aForm := aMorph image rotateBy: 90].
+ aMorph image: aForm.
+ ^ aMorph!
Item was added:
+ ----- Method: ImageMorph class>>defaultForm (in category 'accessing') -----
+ defaultForm
+ ^DefaultForm!
Item was added:
+ ----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Image'
+ categories: #('Graphics' 'Basic')
+ documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.'!
Item was added:
+ ----- Method: ImageMorph class>>fromString: (in category 'instance creation') -----
+ fromString: aString
+ "Create a new ImageMorph which displays the input string in the standard button font"
+
+ ^ self fromString: aString font: Preferences standardButtonFont!
Item was added:
+ ----- Method: ImageMorph class>>fromString:font: (in category 'instance creation') -----
+ fromString: aString font: aFont
+ "Create a new ImageMorph showing the given string in the given font"
+
+ ^ self new image: (StringMorph contents: aString font: aFont) imageForm!
Item was added:
+ ----- Method: ImageMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "ImageMorph initialize"
+
+ | h p d |
+ DefaultForm := (Form extent: 80 at 40 depth: 16).
+ h := DefaultForm height // 2.
+ 0 to: h - 1 do: [:i |
+ p := (i * 2)@i.
+ d := i asFloat / h asFloat.
+ DefaultForm fill:
+ (p corner: DefaultForm extent - p)
+ fillColor: (Color r: d g: 0.5 b: 1.0 - d)].
+
+ self registerInFlapsRegistry.!
Item was added:
+ ----- Method: ImageMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
+ registerInFlapsRegistry
+ "Register the receiver in the system's flaps registry"
+ self environment
+ at: #Flaps
+ ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something')
+ forFlapNamed: 'Supplies']!
Item was added:
+ ----- Method: ImageMorph class>>unload (in category 'class initialization') -----
+ unload
+ "Unload the receiver from global registries"
+
+ self environment at: #Flaps ifPresent: [:cl |
+ cl unregisterQuadsWithReceiver: self] !
Item was added:
+ ----- Method: ImageMorph>>addCustomMenuItems:hand: (in category 'menus') -----
+ addCustomMenuItems: aMenu hand: aHand
+ super addCustomMenuItems: aMenu hand: aHand.
+ aMenu addUpdating: #opacityString action: #changeOpacity!
Item was added:
+ ----- Method: ImageMorph>>borderStyle: (in category 'accessing') -----
+ borderStyle: newStyle
+ | newExtent |
+ newExtent := 2 * newStyle width + image extent.
+ bounds extent = newExtent ifFalse:[super extent: newExtent].
+ super borderStyle: newStyle.!
Item was added:
+ ----- Method: ImageMorph>>borderWidth: (in category 'accessing') -----
+ borderWidth: bw
+ | newExtent |
+ newExtent := 2 * bw + image extent.
+ bounds extent = newExtent ifFalse:[super extent: newExtent].
+ super borderWidth: bw!
Item was added:
+ ----- Method: ImageMorph>>changeOpacity (in category 'menu') -----
+ changeOpacity
+ self isOpaque: self isOpaque not!
Item was added:
+ ----- Method: ImageMorph>>color: (in category 'accessing') -----
+ color: aColor
+ super color: aColor.
+ (image depth = 1 and: [aColor isColor]) ifTrue: [
+ image colors: {Color transparent. aColor}.
+ self changed]!
Item was added:
+ ----- Method: ImageMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | style |
+ (style := self borderStyle) ifNotNil:[
+ style frameRectangle: bounds on: aCanvas.
+ ].
+ self isOpaque
+ ifTrue:[aCanvas drawImage: image at: self innerBounds origin]
+ ifFalse:[aCanvas translucentImage: image at: self innerBounds origin]!
Item was added:
+ ----- Method: ImageMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "Do nothing; my extent is determined by my image Form."
+ !
Item was added:
+ ----- Method: ImageMorph>>form (in category 'accessing') -----
+ form
+ "For compatability with SketchMorph."
+
+ ^ image
+ !
Item was added:
+ ----- Method: ImageMorph>>grabFromScreen (in category 'menu commands') -----
+ grabFromScreen
+
+ self image: Form fromUser.
+ !
Item was added:
+ ----- Method: ImageMorph>>image (in category 'accessing') -----
+ image
+
+ ^ image
+ !
Item was added:
+ ----- Method: ImageMorph>>image: (in category 'accessing') -----
+ image: anImage
+ self changed.
+ image := anImage depth = 1
+ ifTrue: [ColorForm mappingWhiteToTransparentFrom: anImage]
+ ifFalse: [anImage].
+ super extent: image extent!
Item was added:
+ ----- Method: ImageMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ self image: DefaultForm.
+ !
Item was added:
+ ----- Method: ImageMorph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+
+ super initializeToStandAlone.
+ self image: DefaultForm.
+ !
Item was added:
+ ----- Method: ImageMorph>>isImageMorph (in category 'testing') -----
+ isImageMorph
+ ^true!
Item was added:
+ ----- Method: ImageMorph>>isOpaque (in category 'accessing') -----
+ isOpaque
+ "Return true if the receiver is marked as being completely opaque"
+ ^ self
+ valueOfProperty: #isOpaque
+ ifAbsent: [false]!
Item was added:
+ ----- Method: ImageMorph>>isOpaque: (in category 'accessing') -----
+ isOpaque: aBool
+ "Mark the receiver as being completely opaque or not"
+ aBool == false
+ ifTrue:[self removeProperty: #isOpaque]
+ ifFalse:[self setProperty: #isOpaque toValue: aBool].
+ self changed!
Item was added:
+ ----- Method: ImageMorph>>newForm: (in category 'other') -----
+ newForm: aForm
+ self image: aForm!
Item was added:
+ ----- Method: ImageMorph>>opacityString (in category 'menu') -----
+ opacityString
+ ^ (self isOpaque
+ ifTrue: ['<on>']
+ ifFalse: ['<off>']), 'opaque' translated!
Item was added:
+ ----- Method: ImageMorph>>readFromFile (in category 'menu commands') -----
+ readFromFile
+ | fileName |
+ fileName := UIManager default
+ request: 'Please enter the image file name'
+ initialAnswer: 'fileName'.
+ fileName isEmpty ifTrue: [^ self].
+ self image: (Form fromFileNamed: fileName).
+ !
Item was added:
+ ----- Method: ImageMorph>>releaseCachedState (in category 'caching') -----
+ releaseCachedState
+
+ super releaseCachedState.
+ image hibernate.
+ !
Item was added:
+ ----- Method: ImageMorph>>setNewImageFrom: (in category 'accessing') -----
+ setNewImageFrom: formOrNil
+ "Change the receiver's image to be one derived from the supplied form. If nil is supplied, clobber any existing image in the receiver, and in its place put a default graphic, either the one known to the receiver as its default value, else a squeaky mouse"
+
+ | defaultImage |
+ formOrNil ifNotNil: [^ self image: formOrNil].
+ defaultImage := self defaultValueOrNil ifNil: [ScriptingSystem squeakyMouseForm].
+ self image: defaultImage
+ !
Item was added:
+ ----- Method: ImageMorph>>wantsRecolorHandle (in category 'accessing') -----
+ wantsRecolorHandle
+ ^ image notNil and: [image depth = 1]!
Item was added:
+ ----- Method: ImageMorph>>withSnapshotBorder (in category 'accessing') -----
+ withSnapshotBorder
+ self borderStyle: ((ComplexBorder style: #complexFramed)
+ color: (Color
+ r: 0.613
+ g: 1.0
+ b: 0.516);
+ width: 1;
+
+ yourself)!
Item was added:
+ StringMorph subclass: #IndentingListItemMorph
+ instanceVariableNames: 'indentLevel isExpanded complexContents firstChild container nextSibling icon backgroundColor'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
+
+ !IndentingListItemMorph commentStamp: '<historical>' prior: 0!
+ An IndentingListItemMorph is a StringMorph that draws itself with an optional toggle at its left, as part of the display of the SimpleHierarchicalListMorph.
+
+ It will also display lines around the toggle if the #showLinesInHierarchyViews Preference is set.
+
+ Instance variables:
+
+ indentLevel <SmallInteger> the indent level, from 0 at the root and increasing by 1 at each level of the hierarchy.
+
+ isExpanded <Boolean> true if this item is expanded (showing its children)
+
+ complexContents <ListItemWrapper> an adapter wrapping my represented item that can answer its children, etc.
+
+ firstChild <IndentingListItemMorph|nil> my first child, or nil if none
+
+ container <SimpleHierarchicalListMorph> my container
+
+ nextSibling <IndentingListItemMorph|nil> the next item in the linked list of siblings, or nil if none.
+
+ Contributed by Bob Arning as part of the ObjectExplorer package.
+ Don't blame him if it's not perfect. We wanted to get it out for people to play with.!
Item was added:
+ ----- Method: IndentingListItemMorph class>>iconColumnIndex (in category 'defaults') -----
+ iconColumnIndex
+ "Hack. For now, say who gets the icon here. We need a generic solution for icons in multi-column trees. PluggableTreeMorph does something in that direction."
+ ^ 2!
Item was added:
+ ----- Method: IndentingListItemMorph>>acceptDroppingMorph:event: (in category 'drag and drop') -----
+ acceptDroppingMorph: toDrop event: evt
+ complexContents acceptDroppingObject: toDrop complexContents.
+ toDrop delete.
+ self highlightForDrop: false.!
Item was added:
+ ----- Method: IndentingListItemMorph>>addChildrenForList:addingTo:withExpandedItems: (in category 'container protocol - private') -----
+ addChildrenForList: hostList addingTo: morphList withExpandedItems: expandedItems
+
+ firstChild ifNotNil: [
+ firstChild withSiblingsDo: [ :aNode | aNode delete].
+ ].
+ firstChild := nil.
+ complexContents hasContents ifFalse: [^self].
+ firstChild := hostList
+ addMorphsTo: morphList
+ from: complexContents contents
+ allowSorting: true
+ withExpandedItems: expandedItems
+ atLevel: indentLevel + 1.
+ !
Item was added:
+ ----- Method: IndentingListItemMorph>>applyFilter: (in category 'filtering') -----
+ applyFilter: filter
+
+ self
+ applyFilter: filter
+ depthOffset: self indentLevel.!
Item was added:
+ ----- Method: IndentingListItemMorph>>applyFilter:depthOffset: (in category 'filtering') -----
+ applyFilter: filter depthOffset: offset
+
+ | selfMatch childMatch |
+ self isExpanded ifTrue: [self toggleExpandedState].
+
+ selfMatch := self matches: filter.
+ childMatch := self matchesAnyChild: filter depthOffset: offset.
+
+ selfMatch | childMatch ifFalse: [^ self hide].
+
+ selfMatch ifTrue: [
+ self backgroundColor: ((Color gray: 0.85) alpha: 0.5)].
+ childMatch ifTrue: [
+ self toggleExpandedState.
+ self childrenDo: [:child | child applyFilter: filter depthOffset: offset]].!
Item was added:
+ ----- Method: IndentingListItemMorph>>backgroundColor (in category 'accessing') -----
+ backgroundColor
+ ^ backgroundColor!
Item was added:
+ ----- Method: IndentingListItemMorph>>backgroundColor: (in category 'accessing') -----
+ backgroundColor: aColor
+ backgroundColor := aColor.
+ self changed.!
Item was added:
+ ----- Method: IndentingListItemMorph>>balloonText (in category 'accessing') -----
+ balloonText
+
+ ^complexContents balloonText ifNil: [super balloonText]!
Item was added:
+ ----- Method: IndentingListItemMorph>>boundsForBalloon (in category 'halos and balloon help') -----
+ boundsForBalloon
+
+ "some morphs have bounds that are way too big"
+ container ifNil: [^super boundsForBalloon].
+ ^self boundsInWorld intersect: container boundsInWorld!
Item was added:
+ ----- Method: IndentingListItemMorph>>canExpand (in category 'testing') -----
+ canExpand
+
+ ^complexContents hasContents!
Item was added:
+ ----- Method: IndentingListItemMorph>>charactersOccluded (in category 'private') -----
+ charactersOccluded
+ "Answer the number of characters occluded in my #visibleList by my right edge."
+ | listIndex leftEdgeOfRightmostColumn eachString indexOfLastVisible iconWidth totalWidth |
+ listIndex := 0.
+ leftEdgeOfRightmostColumn := container columns
+ ifNil: [ 0 ]
+ ifNotNil:
+ [ : cols | (1 to: cols size - 1)
+ inject: 0
+ into:
+ [ : sum : each | sum + (self widthOfColumn: each) ] ].
+ eachString := container columns
+ ifNil: [ self complexContents asString ]
+ ifNotNil:
+ [ : cols | self contentsAtColumn: container columns size ].
+ iconWidth := self icon
+ ifNil: [ 0 ]
+ ifNotNil:
+ [ : icon | icon width + 2 ].
+ totalWidth := self toggleBounds right.
+ indexOfLastVisible := ((1 to: eachString size)
+ detect:
+ [ : stringIndex | (totalWidth:=totalWidth+(self fontToUse widthOf: (eachString at: stringIndex))) >
+ (container width -
+ (container vIsScrollbarShowing
+ ifTrue: [ container vScrollBar width ]
+ ifFalse: [ 0 ]) - iconWidth - leftEdgeOfRightmostColumn) ]
+ ifNone: [ eachString size + 1 ]) - 1.
+ ^ eachString size - indexOfLastVisible!
Item was added:
+ ----- Method: IndentingListItemMorph>>children (in category 'accessing') -----
+ children
+ | children |
+ children := OrderedCollection new.
+ self childrenDo: [:each | children add: each].
+ ^children!
Item was added:
+ ----- Method: IndentingListItemMorph>>childrenDo: (in category 'enumeration') -----
+ childrenDo: aBlock
+
+ firstChild ifNotNil: [
+ firstChild withSiblingsDo: aBlock ]!
Item was added:
+ ----- Method: IndentingListItemMorph>>collapse (in category 'container protocol') -----
+ collapse
+
+ self isExpanded ifFalse: [^ self].
+
+ self isExpanded: false.
+
+ firstChild ifNotNil: [:collapsingNode |
+ | toDelete |
+ toDelete := OrderedCollection new.
+ collapsingNode withSiblingsDo: [:aNode | aNode recursiveAddTo: toDelete].
+ container noteRemovalOfAll: toDelete].
+
+ self changed.!
Item was added:
+ ----- Method: IndentingListItemMorph>>complexContents (in category 'accessing') -----
+ complexContents
+
+ ^complexContents!
Item was added:
+ ----- Method: IndentingListItemMorph>>contentsAtColumn: (in category 'accessing - columns') -----
+ contentsAtColumn: index
+ "Split string contents at <tab> character."
+
+ | column scanner cell |
+ column := 0.
+ scanner := ReadStream on: contents asString.
+ [(cell := scanner upTo: Character tab) notEmpty]
+ whileTrue: [column := column + 1. column = index ifTrue: [^ cell]].
+ ^ ''!
Item was added:
+ ----- Method: IndentingListItemMorph>>contentsSplitByColumns (in category 'accessing - columns') -----
+ contentsSplitByColumns
+ "Split string contents at <tab> character."
+
+ | result scanner cell |
+ result := OrderedCollection new.
+ scanner := ReadStream on: contents asString.
+ [(cell := scanner upTo: Character tab) notEmpty]
+ whileTrue: [result add: cell].
+ ^ result!
Item was added:
+ ----- Method: IndentingListItemMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+
+ ^complexContents
+ ifNil: [ super defaultColor ]
+ ifNotNil: [ complexContents preferredColor ]!
Item was added:
+ ----- Method: IndentingListItemMorph>>drawLineToggleToTextOn:lineColor:hasToggle: (in category 'drawing') -----
+ drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle
+ "If I am not the only item in my container, draw the line between:
+ - my toggle (if any) or my left edge (if no toggle)
+ - and my text left edge"
+
+ | myBounds myCenter hLineY hLineLeft |
+ self isSoleItem ifTrue: [ ^self ].
+ myBounds := self toggleBounds.
+ myCenter := myBounds center.
+ hLineY := myCenter y.
+ hLineLeft := myCenter x - 1.
+ "Draw line from toggle to text"
+ aCanvas
+ line: hLineLeft @ hLineY
+ to: myBounds right + 0 @ hLineY
+ width: 1
+ color: lineColor!
Item was added:
+ ----- Method: IndentingListItemMorph>>drawLinesOn:lineColor: (in category 'drawing') -----
+ drawLinesOn: aCanvas lineColor: lineColor
+ | hasToggle |
+ hasToggle := self hasToggle.
+ "Draw line from toggle to text"
+ self drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle.
+
+ "Draw the line from my toggle to the nextSibling's toggle"
+ self nextVisibleSibling ifNotNil: [ self drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle ].
+
+ "If I have children and am expanded, draw a line to my first child"
+ (self firstVisibleChild notNil and: [ self isExpanded ])
+ ifTrue: [ self drawLinesToFirstChildOn: aCanvas lineColor: lineColor]!
Item was added:
+ ----- Method: IndentingListItemMorph>>drawLinesToFirstChildOn:lineColor: (in category 'drawing') -----
+ drawLinesToFirstChildOn: aCanvas lineColor: lineColor
+ "Draw line from me to next sibling"
+
+ | child vLineX vLineTop vLineBottom childBounds childCenter |
+ child := self firstVisibleChild.
+ childBounds := child toggleBounds.
+ childCenter := childBounds center.
+ vLineX := childCenter x - 1.
+ vLineTop := bounds bottom.
+ child hasToggle
+ ifTrue: [vLineBottom := childCenter y - 7]
+ ifFalse: [vLineBottom := childCenter y].
+ aCanvas
+ line: vLineX @ vLineTop
+ to: vLineX @ vLineBottom
+ width: 1
+ color: lineColor!
Item was added:
+ ----- Method: IndentingListItemMorph>>drawLinesToNextSiblingOn:lineColor:hasToggle: (in category 'drawing') -----
+ drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle
+ | myBounds nextSibBounds vLineX myCenter vLineTop vLineBottom |
+ myBounds := self toggleBounds.
+ nextSibBounds := self nextVisibleSibling toggleBounds.
+ myCenter := myBounds center.
+ vLineX := myCenter x - 1.
+ vLineTop := myCenter y.
+ vLineBottom := nextSibBounds center y.
+ "Draw line from me to next sibling"
+ aCanvas
+ line: vLineX @ vLineTop
+ to: vLineX @ vLineBottom
+ width: 1
+ color: lineColor!
Item was added:
+ ----- Method: IndentingListItemMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ | tRect sRect columnScanner columnLeft |
+ self backgroundColor ifNotNil: [:c |
+ aCanvas fillRectangle: self innerBounds color: c].
+
+ tRect := self toggleRectangle.
+ self drawToggleOn: aCanvas in: tRect.
+
+ sRect := bounds withLeft: tRect right + 4.
+ sRect := sRect top: sRect top + sRect bottom - self fontToUse height // 2.
+
+ (container columns isNil or: [(contents asString indexOf: Character tab) = 0]) ifTrue: [
+ icon ifNotNil: [
+ aCanvas
+ translucentImage: icon
+ at: sRect left @ (self top + (self height - icon height // 2)).
+ sRect := sRect left: sRect left + icon width + 2.
+ ].
+
+ aCanvas drawString: contents asString in: sRect font: self fontToUse color: color.
+
+ ] ifFalse: [
+ columnLeft := sRect left.
+ columnScanner := ReadStream on: contents asString.
+ container columns withIndexDo: [ :widthSpec :column | | columnRect columnData columnWidth |
+ "Draw icon."
+ column = self class iconColumnIndex ifTrue: [
+ icon ifNotNil: [
+ aCanvas
+ translucentImage: icon
+ at: columnLeft @ (self top + (self height - icon height // 2)).
+ columnLeft := columnLeft + icon width + 2]].
+
+ columnWidth := self widthOfColumn: column.
+ columnRect := columnLeft @ sRect top extent: columnWidth @ sRect height.
+ columnData := columnScanner upTo: Character tab.
+
+ "Draw string."
+ columnData ifNotEmpty: [
+ aCanvas drawString: columnData in: columnRect font: self fontToUse color: color].
+
+ "Compute next column offset."
+ columnLeft := columnRect right + 5.
+ column = 1 ifTrue: [columnLeft := columnLeft - tRect right + self left].
+
+ ].
+ ]!
Item was added:
+ ----- Method: IndentingListItemMorph>>drawToggleOn:in: (in category 'drawing') -----
+ drawToggleOn: aCanvas in: aRectangle
+
+ | aForm centeringOffset |
+ complexContents hasContents ifFalse: [^self].
+ aForm := isExpanded
+ ifTrue: [container expandedForm]
+ ifFalse: [container notExpandedForm].
+ centeringOffset := ((aRectangle height - aForm extent y) / 2.0) rounded.
+ ^aCanvas
+ paintImage: aForm
+ at: (aRectangle topLeft translateBy: 0 @ centeringOffset).
+ !
Item was added:
+ ----- Method: IndentingListItemMorph>>expand (in category 'container protocol') -----
+ expand
+
+ | newChildren c |
+
+ (self isExpanded or: [self canExpand not])
+ ifTrue: [^ self].
+
+ (c := self getChildren) ifEmpty: [
+ "Due to the guessing in #canExpand, it may still fail here."
+ ^ self].
+
+ self isExpanded: true.
+
+ newChildren := container
+ addSubmorphsAfter: self
+ fromCollection: c
+ allowSorting: true.
+
+ firstChild := newChildren first.!
Item was added:
+ ----- Method: IndentingListItemMorph>>firstChild (in category 'accessing') -----
+ firstChild
+
+ ^firstChild!
Item was added:
+ ----- Method: IndentingListItemMorph>>firstVisibleChild (in category 'accessing') -----
+ firstVisibleChild
+
+ ^ self firstChild ifNotNil: [:c |
+ c visible ifTrue: [c] ifFalse: [c nextVisibleSibling]]!
Item was added:
+ ----- Method: IndentingListItemMorph>>getChildren (in category 'model access') -----
+ getChildren
+
+ ^ self getChildrenFor: complexContents!
Item was added:
+ ----- Method: IndentingListItemMorph>>getChildrenFor: (in category 'model access') -----
+ getChildrenFor: model
+
+ ^ model contents!
Item was added:
+ ----- Method: IndentingListItemMorph>>getIcon (in category 'model access') -----
+ getIcon
+
+ ^ complexContents icon!
Item was added:
+ ----- Method: IndentingListItemMorph>>getLabel (in category 'model access') -----
+ getLabel
+
+ ^ self getLabelFor: complexContents!
Item was added:
+ ----- Method: IndentingListItemMorph>>getLabelFor: (in category 'model access') -----
+ getLabelFor: model
+
+ ^ model asString!
Item was added:
+ ----- Method: IndentingListItemMorph>>hMargin (in category 'accessing') -----
+ hMargin
+
+ ^ 3!
Item was added:
+ ----- Method: IndentingListItemMorph>>hasIcon (in category 'testing') -----
+ hasIcon
+ "Answer whether the receiver has an icon."
+ ^ icon notNil!
Item was added:
+ ----- Method: IndentingListItemMorph>>hasToggle (in category 'private') -----
+ hasToggle
+ ^ complexContents hasContents!
Item was added:
+ ----- Method: IndentingListItemMorph>>highlight (in category 'container protocol - private') -----
+ highlight
+
+ (self valueOfProperty: #wasRefreshed ifAbsent: [false])
+ ifFalse: [self color: complexContents highlightingColor]
+ ifTrue: [self color: self color negated].
+
+ self changed.
+
+ !
Item was added:
+ ----- Method: IndentingListItemMorph>>icon (in category 'accessing') -----
+ icon
+ "answer the receiver's icon"
+ ^ icon!
Item was added:
+ ----- Method: IndentingListItemMorph>>inToggleArea: (in category 'mouse events') -----
+ inToggleArea: aPoint
+
+ ^self toggleRectangle containsPoint: aPoint!
Item was added:
+ ----- Method: IndentingListItemMorph>>indentLevel (in category 'accessing') -----
+ indentLevel
+
+ ^indentLevel!
Item was added:
+ ----- Method: IndentingListItemMorph>>initWithContents:prior:forList:indentLevel: (in category 'initialization') -----
+ initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel
+
+ container := hostList.
+
+ complexContents := anObject.
+ anObject addDependent: self.
+
+ self initWithContents: self getLabel font: Preferences standardListFont emphasis: nil.
+ indentLevel := 0.
+ isExpanded := false.
+ nextSibling := firstChild := nil.
+ priorMorph ifNotNil: [
+ priorMorph nextSibling: self.
+ ].
+ indentLevel := newLevel.
+ icon := self getIcon.
+ self extent: self minWidth @ self minHeight!
Item was added:
+ ----- Method: IndentingListItemMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ indentLevel := 0.
+ isExpanded := false!
Item was added:
+ ----- Method: IndentingListItemMorph>>isExpanded (in category 'accessing') -----
+ isExpanded
+
+ ^isExpanded!
Item was added:
+ ----- Method: IndentingListItemMorph>>isExpanded: (in category 'accessing') -----
+ isExpanded: aBoolean
+
+ isExpanded := aBoolean!
Item was added:
+ ----- Method: IndentingListItemMorph>>isFirstItem (in category 'testing') -----
+ isFirstItem
+ ^owner submorphs first == self!
Item was added:
+ ----- Method: IndentingListItemMorph>>isSoleItem (in category 'testing') -----
+ isSoleItem
+ ^self isFirstItem and: [ owner submorphs size = 1 ]!
Item was added:
+ ----- Method: IndentingListItemMorph>>matches: (in category 'filtering') -----
+ matches: pattern
+
+ ^ self matches: pattern in: complexContents!
Item was added:
+ ----- Method: IndentingListItemMorph>>matches:in: (in category 'filtering') -----
+ matches: pattern in: model
+ ^ ((PluggableTreeMorph filterByLabelsOnly
+ ifTrue: [ model itemName ]
+ ifFalse: [ self getLabelFor: model ])
+ findString: pattern
+ startingAt: 1
+ caseSensitive: false) > 0!
Item was added:
+ ----- Method: IndentingListItemMorph>>matchesAnyChild:depthOffset: (in category 'filtering') -----
+ matchesAnyChild: pattern depthOffset: offset
+
+ | maxDepth next current |
+ maxDepth := PluggableTreeMorph maximumSearchDepth - self indentLevel + offset.
+ maxDepth <= 0 ifTrue: [^ false].
+
+ next := (self getChildren collect: [:obj | 1 -> obj]) asOrderedCollection.
+ [next notEmpty] whileTrue: [
+ current := next removeFirst.
+
+ (self matches: pattern in: current value)
+ ifTrue: [^ true].
+
+ current key < maxDepth ifTrue: [
+ next addAll: ((self getChildrenFor: current value) collect: [:obj | (current key + 1) -> obj])].
+ ].
+
+ ^ false!
Item was added:
+ ----- Method: IndentingListItemMorph>>minHeight (in category 'layout') -----
+ minHeight
+ | iconHeight |
+ iconHeight := self hasIcon
+ ifTrue: [self icon height + 2]
+ ifFalse: [0].
+ ^ self fontToUse height max: iconHeight !
Item was added:
+ ----- Method: IndentingListItemMorph>>minWidth (in category 'layout') -----
+ minWidth
+ | iconWidth |
+ iconWidth := self hasIcon
+ ifTrue: [self icon width + 2]
+ ifFalse: [0].
+ ^ (self fontToUse widthOfString: contents)
+ + iconWidth !
Item was added:
+ ----- Method: IndentingListItemMorph>>nextSibling (in category 'accessing') -----
+ nextSibling
+
+ ^nextSibling!
Item was added:
+ ----- Method: IndentingListItemMorph>>nextSibling: (in category 'accessing') -----
+ nextSibling: anotherMorph
+
+ nextSibling := anotherMorph!
Item was added:
+ ----- Method: IndentingListItemMorph>>nextVisibleSibling (in category 'accessing') -----
+ nextVisibleSibling
+
+ | m |
+ m := self nextSibling.
+ [m isNil or: [m visible]] whileFalse: [
+ m := m nextSibling].
+ ^ m!
Item was added:
+ ----- Method: IndentingListItemMorph>>openPath: (in category 'container protocol - private') -----
+ openPath: anArray
+ | found |
+ anArray isEmpty
+ ifTrue: [^ container setSelectedMorph: nil].
+ found := nil.
+ self
+ withSiblingsDo: [:each | found
+ ifNil: [(each complexContents asString = anArray first
+ or: [anArray first isNil])
+ ifTrue: [found := each]]].
+ found
+ ifNil: ["try again with no case sensitivity"
+ self
+ withSiblingsDo: [:each | found
+ ifNil: [(each complexContents asString sameAs: anArray first)
+ ifTrue: [found := each]]]].
+ found
+ ifNotNil: [found isExpanded
+ ifFalse: [found toggleExpandedState.
+ container adjustSubmorphPositions].
+ found changed.
+ anArray size = 1
+ ifTrue: [^ container setSelectedMorph: found].
+ ^ found firstChild
+ ifNil: [container setSelectedMorph: nil]
+ ifNotNil: [found firstChild openPath: anArray allButFirst]].
+ ^ container setSelectedMorph: nil!
Item was added:
+ ----- Method: IndentingListItemMorph>>preferredColumnCount (in category 'accessing - columns') -----
+ preferredColumnCount
+
+ ^ self contentsSplitByColumns size!
Item was added:
+ ----- Method: IndentingListItemMorph>>preferredWidthOfColumn: (in category 'accessing - columns') -----
+ preferredWidthOfColumn: index
+
+ ^ (self fontToUse widthOfString: (self contentsAtColumn: index)) +
+ (index = 1 ifTrue: [self toggleRectangle right - self left] ifFalse: [0])!
Item was added:
+ ----- Method: IndentingListItemMorph>>recursiveAddTo: (in category 'container protocol - private') -----
+ recursiveAddTo: aCollection
+
+ firstChild ifNotNil: [
+ firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection].
+ ].
+ aCollection add: self
+ !
Item was added:
+ ----- Method: IndentingListItemMorph>>recursiveDelete (in category 'container protocol - private') -----
+ recursiveDelete
+
+ firstChild ifNotNil: [
+ firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete].
+ ].
+ self delete
+ !
Item was added:
+ ----- Method: IndentingListItemMorph>>refresh (in category 'initialization') -----
+ refresh
+
+ self contents: self getLabel.
+ icon := self getIcon.
+
+ (self valueOfProperty: #wasRefreshed ifAbsent: [false]) ifFalse: [
+ self setProperty: #wasRefreshed toValue: true.
+ self color: Color yellow. "Indicate refresh operation."].!
Item was added:
+ ----- Method: IndentingListItemMorph>>toggleBounds (in category 'private') -----
+ toggleBounds
+ ^self toggleRectangle!
Item was added:
+ ----- Method: IndentingListItemMorph>>toggleExpandedState (in category 'container protocol') -----
+ toggleExpandedState
+
+ self isExpanded
+ ifTrue: [self collapse]
+ ifFalse: [self expand].!
Item was added:
+ ----- Method: IndentingListItemMorph>>toggleRectangle (in category 'private') -----
+ toggleRectangle
+
+ | h |
+ h := bounds height.
+ ^(bounds left + self hMargin + (12 * indentLevel)) @ bounds top extent: 12 at h!
Item was added:
+ ----- Method: IndentingListItemMorph>>unhighlight (in category 'drawing') -----
+ unhighlight
+
+ (self valueOfProperty: #wasRefreshed ifAbsent: [false])
+ ifFalse: [self color: complexContents preferredColor]
+ ifTrue: [self color: self color negated].
+
+ self changed.
+
+
+ !
Item was added:
+ ----- Method: IndentingListItemMorph>>update: (in category 'updating') -----
+ update: aspect
+ "See ListItemWrapper and subclasses for possible change aspects."
+
+ aspect = #contents ifTrue: [
+ self isExpanded ifTrue: [
+ self toggleExpandedState].
+ self canExpand ifTrue: [self toggleExpandedState]].
+
+ super update: aspect.!
Item was added:
+ ----- Method: IndentingListItemMorph>>userString (in category 'accessing') -----
+ userString
+ "Add leading tabs to my userString"
+ ^ (String new: indentLevel withAll: Character tab), super userString
+ !
Item was added:
+ ----- Method: IndentingListItemMorph>>widthOfColumn: (in category 'accessing - columns') -----
+ widthOfColumn: columnIndex
+ | widthOrSpec |
+ container columns ifNil: [ ^ self width ].
+ widthOrSpec := container columns at: columnIndex.
+ ^ widthOrSpec isNumber
+ ifTrue: [ widthOrSpec ]
+ ifFalse:
+ [ widthOrSpec isBlock
+ ifTrue:
+ [ widthOrSpec
+ cull: container
+ cull: self ]
+ ifFalse:
+ [ widthOrSpec
+ ifNil: [ self width ]
+ ifNotNil: [ "Fall back"
+ 50 ] ] ]!
Item was added:
+ ----- Method: IndentingListItemMorph>>withSiblingsDo: (in category 'private') -----
+ withSiblingsDo: aBlock
+
+ | node |
+ node := self.
+ [node isNil] whileFalse: [
+ aBlock value: node.
+ node := node nextSibling
+ ].!
Item was added:
+ ----- Method: IndentingListItemMorph>>withoutListWrapper (in category 'converting') -----
+ withoutListWrapper
+
+ ^complexContents withoutListWrapper!
Item was added:
+ SimpleBorder subclass: #InsetBorder
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Borders'!
+
+ !InsetBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0!
+ see BorderedMorph!
Item was added:
+ ----- Method: InsetBorder>>bottomRightColor (in category 'accessing') -----
+ bottomRightColor
+ ^width = 1
+ ifTrue: [color twiceLighter]
+ ifFalse: [color lighter]!
Item was added:
+ ----- Method: InsetBorder>>colorsAtCorners (in category 'accessing') -----
+ colorsAtCorners
+ | c c14 c23 |
+ c := self color.
+ c14 := c lighter. c23 := c darker.
+ ^Array with: c23 with: c14 with: c14 with: c23.!
Item was added:
+ ----- Method: InsetBorder>>style (in category 'accessing') -----
+ style
+ ^#inset!
Item was added:
+ ----- Method: InsetBorder>>topLeftColor (in category 'accessing') -----
+ topLeftColor
+ ^width = 1
+ ifTrue: [color twiceDarker]
+ ifFalse: [color darker]!
Item was added:
+ ----- Method: InsetBorder>>trackColorFrom: (in category 'color tracking') -----
+ trackColorFrom: aMorph
+ baseColor ifNil:[self color: aMorph insetColor].!
Item was added:
+ ----- Method: Inspector>>representsSameBrowseeAs: (in category '*morphic') -----
+ representsSameBrowseeAs: anotherInspector
+ ^ self object == anotherInspector object!
Item was added:
+ ----- Method: Integer>>explorerContents (in category '*Morphic-Explorer') -----
+ explorerContents
+
+ ^#(
+ ('hexadecimal' 16)
+ ('octal' 8)
+ ('binary' 2)) collect: [ :each |
+ ObjectExplorerWrapper
+ with: each first translated
+ name: (self printStringBase: each second)
+ model: self ]!
Item was added:
+ ----- Method: Integer>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
+ hasContentsInExplorer
+ ^true!
Item was added:
+ SketchMorph subclass: #JoystickMorph
+ instanceVariableNames: 'handleMorph xScale yScale radiusScale lastAngle autoCenter realJoystickIndex lastRealJoystickValue button1 button2'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !JoystickMorph commentStamp: 'kfr 10/27/2003 16:25' prior: 0!
+ A widget that simulates a joystick. Mosly used in etoy scripting.!
Item was added:
+ ----- Method: JoystickMorph class>>authoringPrototype (in category 'scripting') -----
+ authoringPrototype
+ ^ self new markAsPartsDonor!
Item was added:
+ ----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Joystick'
+ categories: #('Useful')
+ documentation: 'A joystick-like control'!
Item was added:
+ ----- Method: JoystickMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ ^ true!
Item was added:
+ ----- Method: JoystickMorph class>>initialize (in category 'class initialization') -----
+ initialize
+
+ self registerInFlapsRegistry.!
Item was added:
+ ----- Method: JoystickMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
+ registerInFlapsRegistry
+ "Register the receiver in the system's flaps registry"
+ self environment
+ at: #Flaps
+ ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
+ forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
+ forFlapNamed: 'Scripting'.
+ cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
+ forFlapNamed: 'Supplies']!
Item was added:
+ ----- Method: JoystickMorph class>>unload (in category 'class initialization') -----
+ unload
+ "Unload the receiver from global registries"
+
+ self environment at: #Flaps ifPresent: [:cl |
+ cl unregisterQuadsWithReceiver: self] !
Item was added:
+ ----- Method: JoystickMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ "Add custom items to the menu"
+
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu addLine.
+ aCustomMenu add: 'set X range' translated action: #setXRange.
+ aCustomMenu add: 'set Y range' translated action: #setYRange.
+ aCustomMenu addLine.
+ aCustomMenu addUpdating: #autoCenterString target: self action: #toggleAutoCenter.
+ aCustomMenu balloonTextForLastItem: 'When auto-center is on, every time you let go of the Joystick knob, it springs back to the neutral position at the center of the device' translated.
+ aCustomMenu addUpdating: #realJoystickString target: self action: #toggleRealJoystick.
+ aCustomMenu balloonTextForLastItem: 'Governs whether this joystick should track the motions of a real, physical joystick attached to the computer.' translated.
+ aCustomMenu addUpdating: #joystickNumberString enablementSelector: #realJoystickInUse target: self selector: #chooseJoystickNumber argumentList: #().
+ aCustomMenu balloonTextForLastItem: 'Choose which physical device is associated with the joystick.' translated!
Item was added:
+ ----- Method: JoystickMorph>>amount (in category 'accessing') -----
+ amount
+
+ ^ (handleMorph center - self center) r * radiusScale!
Item was added:
+ ----- Method: JoystickMorph>>angle (in category 'accessing') -----
+ angle
+
+ self center = handleMorph center ifTrue: [^ lastAngle].
+ ^ 360.0 - (handleMorph center - self center) theta radiansToDegrees!
Item was added:
+ ----- Method: JoystickMorph>>autoCenterString (in category 'menu') -----
+ autoCenterString
+ "Answer a string characterizing whether or not I have auto-center on"
+
+ ^ (autoCenter == true ifTrue: ['<yes>'] ifFalse: ['<no>']), ('auto-center' translated)!
Item was added:
+ ----- Method: JoystickMorph>>button1 (in category 'accessing') -----
+ button1
+ ^button1 == true!
Item was added:
+ ----- Method: JoystickMorph>>button2 (in category 'accessing') -----
+ button2
+ ^button2 == true!
Item was added:
+ ----- Method: JoystickMorph>>chooseJoystickNumber (in category 'menu') -----
+ chooseJoystickNumber
+ "Allow the user to select a joystick number"
+
+ | result aNumber str |
+ str := self lastRealJoystickIndex asString.
+ result := UIManager default
+ request: ('Joystick device number (currently {1})' translated format: {str})
+ initialAnswer: str.
+ aNumber := [result asNumber] on: Error do: [:err | ^Beeper beep].
+ (aNumber > 0 and: [aNumber <= 32])
+ ifFalse:
+ ["???"
+
+ ^Beeper beep].
+ realJoystickIndex := aNumber.
+ self setProperty: #lastRealJoystickIndex toValue: aNumber.
+ self startStepping!
Item was added:
+ ----- Method: JoystickMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ self inPartsBin ifTrue: [^ false].
+
+ true ifTrue: [^ true]. "5/7/98 jhm temporary fix to allow use when rotated"
+
+ (handleMorph fullContainsPoint: evt cursorPoint)
+ ifTrue: [^ true]
+ ifFalse: [^ super handlesMouseDown: evt].
+ !
Item was added:
+ ----- Method: JoystickMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ xScale := 0.25.
+ yScale := 0.25.
+ radiusScale := 1.0.
+ lastAngle := 0.0.
+ autoCenter := true.
+ self form: ((Form extent: 55 at 55 depth: 8) fillColor: (Color r: 0.3 g: 0.2 b: 0.2)).
+ handleMorph := EllipseMorph new.
+ handleMorph color: Color red; extent: 15 at 15.
+ self addMorph: handleMorph.
+ self moveHandleToCenter.
+ button1 := false.
+ button2 := false.
+ !
Item was added:
+ ----- Method: JoystickMorph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ "Circumvent SketchMorph's implementation here"
+
+ self initialize!
Item was added:
+ ----- Method: JoystickMorph>>isLikelyRecipientForMouseOverHalos (in category 'halos and balloon help') -----
+ isLikelyRecipientForMouseOverHalos
+ "The automatic mouseover halos interere with the proper functioning of the joystick's knob"
+
+ ^ false!
Item was added:
+ ----- Method: JoystickMorph>>joystickNumberString (in category 'menu') -----
+ joystickNumberString
+ "Answer a string characterizing the joystick number"
+
+ ^ 'set real joystick number (now {1})' translated format: {self lastRealJoystickIndex asString}.
+ !
Item was added:
+ ----- Method: JoystickMorph>>lastRealJoystickIndex (in category 'menu') -----
+ lastRealJoystickIndex
+ "Answer the last remembered real joystick index. Initialize it to 1 if need be"
+
+ ^ self valueOfProperty: #lastRealJoystickIndex ifAbsentPut: [1] !
Item was added:
+ ----- Method: JoystickMorph>>leftRight (in category 'accessing') -----
+ leftRight
+
+ ^ (handleMorph center x - self center x) * xScale
+ !
Item was added:
+ ----- Method: JoystickMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ "Make handle track the cursor within my bounds."
+
+ | m r center |
+ m := handleMorph.
+ center := m center.
+ r := m owner innerBounds insetBy:
+ ((center - m fullBounds origin) corner: (m fullBounds corner - center)).
+ m position: (evt cursorPoint adhereTo: r) - (m extent // 2).
+ !
Item was added:
+ ----- Method: JoystickMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+
+ lastAngle := self angle.
+ autoCenter ifTrue: [self moveHandleToCenter].
+ !
Item was added:
+ ----- Method: JoystickMorph>>moveHandleToCenter (in category 'other') -----
+ moveHandleToCenter
+
+ handleMorph position: self center - (handleMorph extent // 2).
+ !
Item was added:
+ ----- Method: JoystickMorph>>realJoystickInUse (in category 'menu') -----
+ realJoystickInUse
+ "Answer whether a real joystick is in use"
+
+ ^ realJoystickIndex notNil!
Item was added:
+ ----- Method: JoystickMorph>>realJoystickString (in category 'menu') -----
+ realJoystickString
+ "Answer a string characterizing whether or not I am currenty tracking a real joystick"
+
+ ^ (realJoystickIndex ifNil: ['<no>'] ifNotNil: ['<yes>']), ('track real joystick' translated)!
Item was added:
+ ----- Method: JoystickMorph>>setXRange (in category 'menu') -----
+ setXRange
+
+ | range |
+ range := UIManager default
+ request:
+ 'Type the maximum value for the X axis' translated
+ initialAnswer: ((xScale * (self width - handleMorph width) / 2.0) printShowingMaxDecimalPlaces: 2).
+ range isEmpty ifFalse: [
+ xScale := (2.0 * range asNumber asFloat) / (self width - handleMorph width)].
+ !
Item was added:
+ ----- Method: JoystickMorph>>setYRange (in category 'menu') -----
+ setYRange
+
+ | range |
+ range := UIManager default
+ request:
+ 'Type the maximum value for the Y axis' translated
+ initialAnswer: ((yScale * (self width - handleMorph width) / 2.0) printShowingMaxDecimalPlaces: 2).
+ range isEmpty ifFalse: [
+ yScale := (2.0 * range asNumber asFloat) / (self width - handleMorph width)].
+ !
Item was added:
+ ----- Method: JoystickMorph>>step (in category 'stepping and presenter') -----
+ step
+ "Track the real joystick whose index is realJoystickIndex."
+ "Details:
+ a. if realJoystickIndex is nil we're not tracking a joystick
+ b. [-joyMax..joyMax] is nominal range of joystick in both X and Y
+ c. [-threshold..threshold] is considered 0 to compensate for poor joystick centering"
+
+ | threshold joyMax joyPt joyBtn m mCenter r scaledPt |
+ super step. "Run ticking user-written scripts if any"
+ realJoystickIndex ifNil: [^ self].
+ threshold := 30.
+ joyMax := 350.
+ joyPt := Sensor joystickXY: realJoystickIndex.
+ joyBtn := Sensor joystickButtons: realJoystickIndex.
+
+ button1 := (joyBtn bitAnd: 1) > 0.
+ button2 := (joyBtn bitAnd: 2) > 0.
+
+ joyPt x abs < threshold ifTrue: [joyPt := 0 at joyPt y].
+ joyPt y abs < threshold ifTrue: [joyPt := joyPt x at 0].
+ lastRealJoystickValue = joyPt ifTrue: [^ self].
+ lastRealJoystickValue := joyPt.
+ m := handleMorph.
+ mCenter := m center.
+ r := m owner innerBounds insetBy:
+ ((mCenter - m fullBounds origin) corner: (m fullBounds corner - mCenter)).
+ scaledPt := r center + ((r extent * joyPt) / (joyMax * 2)) truncated.
+ m position: (scaledPt adhereTo: r) - (m extent // 2).
+ !
Item was added:
+ ----- Method: JoystickMorph>>stepTime (in category 'stepping and presenter') -----
+ stepTime
+ "Provide for as-fast-as-possible stepping in the case of a real joystick"
+
+ ^ realJoystickIndex
+ ifNotNil:
+ [0] "fast as we can to track actual joystick"
+ ifNil:
+ [super stepTime]!
Item was added:
+ ----- Method: JoystickMorph>>stopTrackingJoystick (in category 'menu') -----
+ stopTrackingJoystick
+
+ realJoystickIndex := nil.
+ self stopStepping.
+ !
Item was added:
+ ----- Method: JoystickMorph>>toggleAutoCenter (in category 'menu') -----
+ toggleAutoCenter
+
+ autoCenter := autoCenter not.
+ autoCenter ifTrue: [self moveHandleToCenter].
+ !
Item was added:
+ ----- Method: JoystickMorph>>toggleRealJoystick (in category 'menu') -----
+ toggleRealJoystick
+ "Toggle whether or not one is using a real joystick"
+
+ realJoystickIndex
+ ifNil:
+ [realJoystickIndex := self valueOfProperty: #lastRealJoystickIndex ifAbsentPut: [1].
+ self startStepping]
+ ifNotNil:
+ [self stopTrackingJoystick]!
Item was added:
+ ----- Method: JoystickMorph>>trackRealJoystick (in category 'menu') -----
+ trackRealJoystick
+
+ | s |
+ s := UIManager default
+ request: 'Number of joystick to track?'
+ initialAnswer: '1'.
+ s isEmpty ifTrue: [^ self].
+ realJoystickIndex := Number readFromString: s.
+ self startStepping.
+ !
Item was added:
+ ----- Method: JoystickMorph>>upDown (in category 'accessing') -----
+ upDown
+
+ ^ (self center y - handleMorph center y) * yScale
+ !
Item was added:
+ Object subclass: #KeyboardBuffer
+ instanceVariableNames: 'event eventUsed'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
Item was added:
+ ----- Method: KeyboardBuffer>>commandKeyPressed (in category 'as yet unclassified') -----
+ commandKeyPressed
+ ^ event commandKeyPressed!
Item was added:
+ ----- Method: KeyboardBuffer>>controlKeyPressed (in category 'as yet unclassified') -----
+ controlKeyPressed
+ ^ event controlKeyPressed!
Item was added:
+ ----- Method: KeyboardBuffer>>flushKeyboard (in category 'as yet unclassified') -----
+ flushKeyboard
+ eventUsed ifFalse: [^ eventUsed := true].!
Item was added:
+ ----- Method: KeyboardBuffer>>keyboard (in category 'as yet unclassified') -----
+ keyboard
+ eventUsed ifFalse: [eventUsed := true. ^ event keyCharacter].
+ ^ nil!
Item was added:
+ ----- Method: KeyboardBuffer>>keyboardPeek (in category 'as yet unclassified') -----
+ keyboardPeek
+ eventUsed ifFalse: [^ event keyCharacter].
+ ^ nil!
Item was added:
+ ----- Method: KeyboardBuffer>>keyboardPressed (in category 'as yet unclassified') -----
+ keyboardPressed
+ ^eventUsed not!
Item was added:
+ ----- Method: KeyboardBuffer>>leftShiftDown (in category 'as yet unclassified') -----
+ leftShiftDown
+ ^ event shiftPressed!
Item was added:
+ ----- Method: KeyboardBuffer>>startingEvent: (in category 'as yet unclassified') -----
+ startingEvent: evt
+ event := evt.
+ eventUsed := false!
Item was added:
+ UserInputEvent subclass: #KeyboardEvent
+ instanceVariableNames: 'keyValue'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: KeyboardEvent>>= (in category 'comparing') -----
+ = aMorphicEvent
+ super = aMorphicEvent ifFalse:[^false].
+ buttons = aMorphicEvent buttons ifFalse: [^ false].
+ keyValue = aMorphicEvent keyValue ifFalse: [^ false].
+ ^ true
+ !
Item was added:
+ ----- Method: KeyboardEvent>>hash (in category 'comparing') -----
+ hash
+ ^buttons hash + keyValue hash
+ !
Item was added:
+ ----- Method: KeyboardEvent>>isKeyDown (in category 'testing') -----
+ isKeyDown
+ ^self type == #keyDown!
Item was added:
+ ----- Method: KeyboardEvent>>isKeyUp (in category 'testing') -----
+ isKeyUp
+ ^self type == #keyUp!
Item was added:
+ ----- Method: KeyboardEvent>>isKeyboard (in category 'testing') -----
+ isKeyboard
+ ^true!
Item was added:
+ ----- Method: KeyboardEvent>>isKeystroke (in category 'testing') -----
+ isKeystroke
+ ^self type == #keystroke!
Item was added:
+ ----- Method: KeyboardEvent>>isMouseMove (in category 'testing') -----
+ isMouseMove
+ ^false!
Item was added:
+ ----- Method: KeyboardEvent>>keyCharacter (in category 'keyboard') -----
+ keyCharacter
+ "Answer the character corresponding this keystroke. This is defined only for keystroke events."
+
+ ^ keyValue asCharacter!
Item was added:
+ ----- Method: KeyboardEvent>>keyString (in category 'keyboard') -----
+ keyString
+ "Answer the string value for this keystroke. This is defined only for keystroke events."
+
+ ^ String streamContents: [ :s | self printKeyStringOn: s ]!
Item was added:
+ ----- Method: KeyboardEvent>>keyValue (in category 'keyboard') -----
+ keyValue
+ "Answer the ascii value for this keystroke. This is defined only for keystroke events."
+
+ ^ keyValue!
Item was added:
+ ----- Method: KeyboardEvent>>printKeyStringOn: (in category 'printing') -----
+ printKeyStringOn: aStream
+ "Print a readable string representing the receiver on a given stream"
+
+ | kc inBrackets firstBracket keyString |
+ kc := self keyCharacter.
+ inBrackets := false.
+ firstBracket := [ inBrackets ifFalse: [ aStream nextPut: $<. inBrackets := true ]].
+ self controlKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Ctrl-' ].
+ self commandKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Cmd-' ].
+ (buttons anyMask: 32) ifTrue: [ firstBracket value. aStream nextPutAll: 'Opt-' ].
+ (self shiftPressed and: [ keyValue between: 1 and: 31 ])
+ ifTrue: [ firstBracket value. aStream nextPutAll: 'Shift-' ].
+
+ (self controlKeyPressed and: [ keyValue <= 26 ])
+ ifTrue:
+ [aStream nextPut: (keyValue + $a asciiValue - 1) asCharacter]
+ ifFalse:
+ [keyString := (kc caseOf: {
+ [ Character space ] -> [ ' ' ].
+ [ Character tab ] -> [ 'tab' ].
+ [ Character cr ] -> [ 'cr' ].
+ [ Character lf ] -> [ 'lf' ].
+ [ Character enter ] -> [ 'enter' ].
+
+ [ Character backspace ] -> [ 'backspace' ].
+ [ Character delete ] -> [ 'delete' ].
+
+ [ Character escape ] -> [ 'escape' ].
+
+ [ Character arrowDown ] -> [ 'down' ].
+ [ Character arrowUp ] -> [ 'up' ].
+ [ Character arrowLeft ] -> [ 'left' ].
+ [ Character arrowRight ] -> [ 'right' ].
+
+ [ Character end ] -> [ 'end' ].
+ [ Character home ] -> [ 'home' ].
+ [ Character pageDown ] -> [ 'pageDown' ].
+ [ Character pageUp ] -> [ 'pageUp' ].
+
+ [ Character euro ] -> [ 'euro' ].
+ [ Character insert ] -> [ 'insert' ].
+
+ } otherwise: [ String with: kc ]).
+ keyString size > 1 ifTrue: [ firstBracket value ].
+ aStream nextPutAll: keyString].
+
+ inBrackets ifTrue: [aStream nextPut: $> ]!
Item was added:
+ ----- Method: KeyboardEvent>>printOn: (in category 'printing') -----
+ printOn: aStream
+ "Print the receiver on a stream"
+
+ aStream nextPut: $[.
+ aStream nextPutAll: type; nextPutAll: ' '''.
+ self printKeyStringOn: aStream.
+ aStream nextPut: $'.
+ aStream nextPut: $]!
Item was added:
+ ----- Method: KeyboardEvent>>scanCode: (in category 'private') -----
+ scanCode: ignore
+ " OB-Tests expects this "!
Item was added:
+ ----- Method: KeyboardEvent>>sentTo: (in category 'dispatching') -----
+ sentTo: aMorph
+ "Dispatch the receiver into the given morph or another one if keyboard focus changes."
+
+ | receivingMorph |
+ receivingMorph := aMorph.
+ aMorph wantsKeyboardFocus ifTrue: [
+ receivingMorph := (self hand newKeyboardFocus: aMorph) ifNil: [aMorph]].
+
+ type == #keystroke ifTrue:[^receivingMorph handleKeystroke: self].
+ type == #keyDown ifTrue:[^receivingMorph handleKeyDown: self].
+ type == #keyUp ifTrue:[^receivingMorph handleKeyUp: self].
+
+ ^super sentTo: receivingMorph!
Item was added:
+ ----- Method: KeyboardEvent>>setType:buttons:position:keyValue:charCode:hand:stamp: (in category 'private') -----
+ setType: aSymbol buttons: anInteger position: pos keyValue: aValue charCode: ignoredUsedInOBTesting hand: aHand stamp: stamp
+ self setType: aSymbol buttons: anInteger position: pos keyValue: aValue hand: aHand stamp: stamp!
Item was added:
+ ----- Method: KeyboardEvent>>setType:buttons:position:keyValue:hand:stamp: (in category 'private') -----
+ setType: aSymbol buttons: anInteger position: pos keyValue: aValue hand: aHand stamp: stamp
+ type := aSymbol.
+ buttons := anInteger.
+ position := pos.
+ keyValue := aValue.
+ source := aHand.
+ wasHandled := false.
+ timeStamp := stamp.!
Item was added:
+ ----- Method: KeyboardEvent>>storeOn: (in category 'printing') -----
+ storeOn: aStream
+
+ aStream nextPutAll: type.
+ aStream space.
+ self timeStamp storeOn: aStream.
+ aStream space.
+ buttons storeOn: aStream.
+ aStream space.
+ keyValue storeOn: aStream.
+ !
Item was added:
+ ----- Method: KeyboardEvent>>type:readFrom: (in category 'initialize') -----
+ type: eventType readFrom: aStream
+ type := eventType.
+ timeStamp := Integer readFrom: aStream.
+ aStream skip: 1.
+ buttons := Integer readFrom: aStream.
+ aStream skip: 1.
+ keyValue := Integer readFrom: aStream.!
Item was added:
+ Object subclass: #LayoutCell
+ instanceVariableNames: 'target cellSize extraSpace flags nextCell'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Layouts'!
+
+ !LayoutCell commentStamp: '<historical>' prior: 0!
+ I am used in table layouts to hold temporary values while the layout is being computed.
+
+ Instance variables:
+ target <Morph> The morph contained in this cell
+ cellSize <Point> The size of the cell
+ extraSpace <nil | Point> Additional space to add after this cell
+ nextCell <nil | LayoutCell> The next cell in the arrangement.
+
+ Implementation note:
+ Both, cellSize and extraSpace contains points where
+ x - represents the primary table direction
+ y - represents the secondary table direction
+ !
Item was added:
+ ----- Method: LayoutCell>>addExtraSpace: (in category 'accessing') -----
+ addExtraSpace: aPoint
+ extraSpace
+ ifNil:[extraSpace := aPoint]
+ ifNotNil:[extraSpace := extraSpace + aPoint]!
Item was added:
+ ----- Method: LayoutCell>>cellSize (in category 'accessing') -----
+ cellSize
+ ^cellSize!
Item was added:
+ ----- Method: LayoutCell>>cellSize: (in category 'accessing') -----
+ cellSize: aPoint
+ cellSize := aPoint!
Item was added:
+ ----- Method: LayoutCell>>do: (in category 'collection') -----
+ do: aBlock
+ aBlock value: self.
+ nextCell ifNotNil:[nextCell do: aBlock].!
Item was added:
+ ----- Method: LayoutCell>>extraSpace (in category 'accessing') -----
+ extraSpace
+ ^extraSpace ifNil:[0 at 0]!
Item was added:
+ ----- Method: LayoutCell>>extraSpace: (in category 'accessing') -----
+ extraSpace: aPoint
+ extraSpace := aPoint!
Item was added:
+ ----- Method: LayoutCell>>flags (in category 'accessing') -----
+ flags
+ ^flags ifNil: [ 0 ]!
Item was added:
+ ----- Method: LayoutCell>>hSpaceFill (in category 'accessing') -----
+ hSpaceFill
+ ^self flags anyMask: 1!
Item was added:
+ ----- Method: LayoutCell>>hSpaceFill: (in category 'accessing') -----
+ hSpaceFill: aBool
+ flags := aBool ifTrue:[self flags bitOr: 1] ifFalse:[self flags bitClear: 1].
+ !
Item was added:
+ ----- Method: LayoutCell>>inject:into: (in category 'collection') -----
+ inject: thisValue into: binaryBlock
+ "Accumulate a running value associated with evaluating the argument,
+ binaryBlock, with the current value of the argument, thisValue, and the
+ receiver as block arguments. For instance, to sum the numeric elements
+ of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal +
+ next]."
+
+ | nextValue |
+ nextValue := thisValue.
+ self do: [:each | nextValue := binaryBlock value: nextValue value: each].
+ ^nextValue!
Item was added:
+ ----- Method: LayoutCell>>nextCell (in category 'accessing') -----
+ nextCell
+ ^nextCell!
Item was added:
+ ----- Method: LayoutCell>>nextCell: (in category 'accessing') -----
+ nextCell: aCell
+ nextCell := aCell!
Item was added:
+ ----- Method: LayoutCell>>size (in category 'accessing') -----
+ size
+ | n cell |
+ n := 0.
+ cell := self.
+ [cell isNil] whileFalse:
+ [n := n + 1.
+ cell := cell nextCell].
+ ^n!
Item was added:
+ ----- Method: LayoutCell>>target (in category 'accessing') -----
+ target
+ ^target!
Item was added:
+ ----- Method: LayoutCell>>target: (in category 'accessing') -----
+ target: newTarget
+ target := newTarget!
Item was added:
+ ----- Method: LayoutCell>>vSpaceFill (in category 'accessing') -----
+ vSpaceFill
+ ^self flags anyMask: 2!
Item was added:
+ ----- Method: LayoutCell>>vSpaceFill: (in category 'accessing') -----
+ vSpaceFill: aBool
+ flags := aBool ifTrue:[self flags bitOr: 2] ifFalse:[self flags bitClear: 2].
+ !
Item was added:
+ Object subclass: #LayoutPolicy
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Layouts'!
+
+ !LayoutPolicy commentStamp: '<historical>' prior: 0!
+ A LayoutPolicy defines how submorphs of some morph should be arranged. Subclasses of the receiver define concrete layout policies.!
Item was added:
+ ----- Method: LayoutPolicy>>flushLayoutCache (in category 'layout') -----
+ flushLayoutCache
+ "Flush any cached information associated with the receiver"!
Item was added:
+ ----- Method: LayoutPolicy>>indexForInserting:at:in: (in category 'utilities') -----
+ indexForInserting: aMorph at: aPoint in: someMorph
+ "Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion."
+ ^1 "front-most"!
Item was added:
+ ----- Method: LayoutPolicy>>isProportionalLayout (in category 'testing') -----
+ isProportionalLayout
+ ^false!
Item was added:
+ ----- Method: LayoutPolicy>>isTableLayout (in category 'testing') -----
+ isTableLayout
+ ^false!
Item was added:
+ ----- Method: LayoutPolicy>>layout:in: (in category 'layout') -----
+ layout: aMorph in: newBounds
+ "Compute the layout for the given morph based on the new bounds"
+ !
Item was added:
+ ----- Method: LayoutPolicy>>minExtentOf:in: (in category 'layout') -----
+ minExtentOf: aMorph in: newBounds
+ "Return the minimal size aMorph's children would require given the new bounds"
+ ^0 at 0!
Item was added:
+ Object subclass: #LayoutProperties
+ instanceVariableNames: 'hResizing vResizing disableLayout'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Layouts'!
+
+ !LayoutProperties commentStamp: '<historical>' prior: 0!
+ This class provides a compact bit encoding for the most commonly used layout properties.!
Item was added:
+ ----- Method: LayoutProperties>>asTableLayoutProperties (in category 'converting') -----
+ asTableLayoutProperties
+ ^(TableLayoutProperties new)
+ hResizing: self hResizing;
+ vResizing: self vResizing;
+ disableTableLayout: self disableTableLayout;
+ yourself!
Item was added:
+ ----- Method: LayoutProperties>>cellInset (in category 'table defaults') -----
+ cellInset
+ "Default"
+ ^0!
Item was added:
+ ----- Method: LayoutProperties>>cellPositioning (in category 'table defaults') -----
+ cellPositioning
+ ^#center!
Item was added:
+ ----- Method: LayoutProperties>>cellSpacing (in category 'table defaults') -----
+ cellSpacing
+ "Default"
+ ^#none!
Item was added:
+ ----- Method: LayoutProperties>>disableTableLayout (in category 'accessing') -----
+ disableTableLayout
+ ^disableLayout!
Item was added:
+ ----- Method: LayoutProperties>>disableTableLayout: (in category 'accessing') -----
+ disableTableLayout: aBool
+ disableLayout := aBool!
Item was added:
+ ----- Method: LayoutProperties>>hResizing (in category 'accessing') -----
+ hResizing
+ ^hResizing!
Item was added:
+ ----- Method: LayoutProperties>>hResizing: (in category 'accessing') -----
+ hResizing: aSymbol
+ hResizing := aSymbol!
Item was added:
+ ----- Method: LayoutProperties>>includesTableProperties (in category 'testing') -----
+ includesTableProperties
+ ^false!
Item was added:
+ ----- Method: LayoutProperties>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ hResizing := vResizing := #rigid.
+ disableLayout := false.!
Item was added:
+ ----- Method: LayoutProperties>>initializeFrom: (in category 'initialize') -----
+ initializeFrom: defaultProvider
+ "Initialize the receiver from a default provider"
+ self hResizing: defaultProvider hResizing.
+ self vResizing: defaultProvider vResizing.
+ self disableTableLayout: defaultProvider disableTableLayout.!
Item was added:
+ ----- Method: LayoutProperties>>layoutInset (in category 'table defaults') -----
+ layoutInset
+ ^0!
Item was added:
+ ----- Method: LayoutProperties>>listCentering (in category 'table defaults') -----
+ listCentering
+ "Default"
+ ^#topLeft!
Item was added:
+ ----- Method: LayoutProperties>>listDirection (in category 'table defaults') -----
+ listDirection
+ "Default"
+ ^#topToBottom!
Item was added:
+ ----- Method: LayoutProperties>>listSpacing (in category 'table defaults') -----
+ listSpacing
+ "Default"
+ ^#none!
Item was added:
+ ----- Method: LayoutProperties>>maxCellSize (in category 'table defaults') -----
+ maxCellSize
+ ^SmallInteger maxVal!
Item was added:
+ ----- Method: LayoutProperties>>minCellSize (in category 'table defaults') -----
+ minCellSize
+ ^0!
Item was added:
+ ----- Method: LayoutProperties>>reverseTableCells (in category 'table defaults') -----
+ reverseTableCells
+ ^false!
Item was added:
+ ----- Method: LayoutProperties>>rubberBandCells (in category 'table defaults') -----
+ rubberBandCells
+ ^false!
Item was added:
+ ----- Method: LayoutProperties>>vResizing (in category 'accessing') -----
+ vResizing
+ ^vResizing!
Item was added:
+ ----- Method: LayoutProperties>>vResizing: (in category 'accessing') -----
+ vResizing: aSymbol
+ vResizing := aSymbol!
Item was added:
+ ----- Method: LayoutProperties>>wrapCentering (in category 'table defaults') -----
+ wrapCentering
+ ^#topLeft!
Item was added:
+ ----- Method: LayoutProperties>>wrapDirection (in category 'table defaults') -----
+ wrapDirection
+ ^#none!
Item was added:
+ Morph subclass: #LazyListMorph
+ instanceVariableNames: 'listItems listIcons font selectedRow selectedRows preSelectedRow listSource maxWidth'
+ classVariableNames: 'ListPreSelectionColor ListSelectionColor ListSelectionTextColor'
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !LazyListMorph commentStamp: 'efc 8/6/2005 11:34' prior: 0!
+ The morph that displays the list in a PluggableListMorph. It is "lazy" because it will only request the list items that it actually needs to display.
+
+ I will cache the maximum width of my items in maxWidth to avoid this potentially expensive and frequent computation.!
Item was added:
+ ----- Method: LazyListMorph class>>listPreSelectionColor (in category 'preferences') -----
+ listPreSelectionColor
+ <preference: 'List Pre Selection Color'
+ category: 'colors'
+ description: 'Governs the color of pre selection highlight in lists'
+ type: #Color>
+ ^ ListPreSelectionColor ifNil: [Color r: 0.9 g: 0.9 b: 0.9]!
Item was added:
+ ----- Method: LazyListMorph class>>listSelectionColor (in category 'preferences') -----
+ listSelectionColor
+ <preference: 'List Selection Color'
+ category: 'colors'
+ description: 'Governs the selection background in lists'
+ type: #Color>
+ ^ ListSelectionColor ifNil: [Color r: 0.72 g: 0.72 b: 0.9]!
Item was added:
+ ----- Method: LazyListMorph class>>listSelectionColor: (in category 'preferences') -----
+ listSelectionColor: aColor
+
+ ListSelectionColor := aColor.
+ World invalidRect: World bounds from: World.!
Item was added:
+ ----- Method: LazyListMorph class>>listSelectionTextColor (in category 'preferences') -----
+ listSelectionTextColor
+ <preference: 'List Selection Text Color'
+ category: 'colors'
+ description: 'Governs the color of selected text in lists'
+ type: #Color>
+ ^ ListSelectionTextColor ifNil: [Color black]!
Item was added:
+ ----- Method: LazyListMorph class>>listSelectionTextColor: (in category 'preferences') -----
+ listSelectionTextColor: aColor
+
+ ListSelectionTextColor := aColor.
+ World invalidRect: World bounds from: World.!
Item was added:
+ ----- Method: LazyListMorph>>adjustHeight (in category 'drawing') -----
+ adjustHeight
+ "private. Adjust our height to match the length of the underlying list"
+ self height: (listItems size max: 1) * font height
+ !
Item was added:
+ ----- Method: LazyListMorph>>adjustWidth (in category 'drawing') -----
+ adjustWidth
+ "private. Adjust our height to match the length of the underlying list"
+ self width: ((listSource width max: self hUnadjustedScrollRange) + 20).
+ !
Item was added:
+ ----- Method: LazyListMorph>>bottomVisibleRowForCanvas: (in category 'drawing') -----
+ bottomVisibleRowForCanvas: aCanvas
+ "return the bottom visible row in aCanvas's clip rectangle"
+ ^self rowAtLocation: aCanvas clipRect bottomLeft.
+ !
Item was added:
+ ----- Method: LazyListMorph>>colorForRow: (in category 'drawing') -----
+ colorForRow: row
+
+ ^(selectedRow notNil and: [ row = selectedRow])
+ ifTrue: [ self class listSelectionTextColor ]
+ ifFalse: [ self color ].!
Item was added:
+ ----- Method: LazyListMorph>>display:atRow:on: (in category 'drawing') -----
+ display: item atRow: row on: canvas
+ "display the given item at row row"
+
+ | drawBounds emphasized rowColor itemAsText |
+ itemAsText := item asStringOrText.
+ emphasized := itemAsText isText
+ ifTrue: [font emphasized: (itemAsText emphasisAt: 1)]
+ ifFalse: [font].
+ rowColor := self colorForRow: row.
+ drawBounds := (self drawBoundsForRow: row) translateBy: (self hMargin @ 0).
+ drawBounds := drawBounds intersect: self bounds.
+ (self icon: row) ifNotNil:
+ [ :icon || top |
+ top := drawBounds top + ((drawBounds height - icon height) // 2).
+ canvas translucentImage: icon at: drawBounds left @ top.
+ drawBounds := drawBounds left: drawBounds left + icon width + 2 ].
+ canvas drawString: itemAsText in: drawBounds font: emphasized color: rowColor!
Item was added:
+ ----- Method: LazyListMorph>>drawBackgroundForMulti:on: (in category 'drawing') -----
+ drawBackgroundForMulti: row on: aCanvas
+ "shade the background paler, if this row is selected, but not the current selected row"
+ | selectionDrawBounds thisColor |
+ thisColor := selectedRow = row
+ ifTrue: [ self class listSelectionColor twiceDarker ]
+ ifFalse: [ self class listSelectionColor ].
+ selectionDrawBounds := self drawBoundsForRow: row.
+ selectionDrawBounds := selectionDrawBounds intersect: self bounds.
+ aCanvas
+ fillRectangle: selectionDrawBounds
+ color: thisColor!
Item was added:
+ ----- Method: LazyListMorph>>drawBackgroundForPotentialDrop:on: (in category 'drawing') -----
+ drawBackgroundForPotentialDrop: row on: aCanvas
+ | selectionDrawBounds |
+ "shade the background darker, if this row is a potential drop target"
+
+ selectionDrawBounds := self drawBoundsForRow: row.
+ selectionDrawBounds := selectionDrawBounds intersect: self bounds.
+ aCanvas fillRectangle: selectionDrawBounds color: self color muchLighter darker!
Item was added:
+ ----- Method: LazyListMorph>>drawBoundsForRow: (in category 'list management') -----
+ drawBoundsForRow: row
+ "calculate the bounds that row should be drawn at. This might be outside our bounds!!"
+ | topLeft drawBounds |
+ topLeft := self topLeft x @ (self topLeft y + ((row - 1) * (font height))).
+ drawBounds := topLeft extent: self width @ font height.
+ ^drawBounds!
Item was added:
+ ----- Method: LazyListMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | |
+ listItems size = 0 ifTrue: [ ^self ].
+
+ self
+ drawPreSelectionOn: aCanvas;
+ drawSelectionOn: aCanvas.
+
+ (self topVisibleRowForCanvas: aCanvas) to: (self bottomVisibleRowForCanvas: aCanvas) do: [ :row |
+ (listSource itemSelectedAmongMultiple: row) ifTrue: [
+ self drawBackgroundForMulti: row on: aCanvas. ]].
+
+ PluggableListMorph highlightHoveredRow ifTrue: [
+ listSource hoverRow > 0 ifTrue: [
+ self highlightHoverRow: listSource hoverRow on: aCanvas ] ].
+
+ (self topVisibleRowForCanvas: aCanvas) to: (self bottomVisibleRowForCanvas: aCanvas) do: [ :row |
+ self display: (self item: row) atRow: row on: aCanvas.
+ ].
+
+ listSource potentialDropRow > 0 ifTrue: [
+ self highlightPotentialDropRow: listSource potentialDropRow on: aCanvas ].!
Item was added:
+ ----- Method: LazyListMorph>>drawPreSelectionOn: (in category 'drawing') -----
+ drawPreSelectionOn: aCanvas
+
+ self
+ drawSelectionFor: preSelectedRow
+ withColor: self class listPreSelectionColor
+ on: aCanvas!
Item was added:
+ ----- Method: LazyListMorph>>drawSelectionFor:withColor:on: (in category 'drawing') -----
+ drawSelectionFor: index withColor: color on: aCanvas
+
+ | selectionDrawBounds |
+ index ifNil: [ ^self ].
+ index = 0 ifTrue: [ ^self ].
+ selectionDrawBounds := self drawBoundsForRow: index.
+ selectionDrawBounds := selectionDrawBounds intersect: self bounds.
+ aCanvas fillRectangle: selectionDrawBounds color: color.!
Item was added:
+ ----- Method: LazyListMorph>>drawSelectionOn: (in category 'drawing') -----
+ drawSelectionOn: aCanvas
+
+ self
+ drawSelectionFor: selectedRow
+ withColor: self class listSelectionColor
+ on: aCanvas!
Item was added:
+ ----- Method: LazyListMorph>>font (in category 'drawing') -----
+ font
+ "return the font used for drawing. The response is never nil"
+ ^font!
Item was added:
+ ----- Method: LazyListMorph>>font: (in category 'drawing') -----
+ font: newFont
+ font := (newFont ifNil: [ TextStyle default defaultFont ]).
+ self adjustHeight.
+ self changed.!
Item was added:
+ ----- Method: LazyListMorph>>getListItem: (in category 'list access') -----
+ getListItem: index
+ "grab a list item directly from the model"
+ ^listSource getListItem: index!
Item was added:
+ ----- Method: LazyListMorph>>getListSize (in category 'list access') -----
+ getListSize
+ "return the number of items in the list"
+ listSource ifNil: [ ^0 ].
+ ^listSource getListSize!
Item was added:
+ ----- Method: LazyListMorph>>hMargin (in category 'accessing') -----
+ hMargin
+
+ ^ 3!
Item was added:
+ ----- Method: LazyListMorph>>hUnadjustedScrollRange (in category 'scroll range') -----
+ hUnadjustedScrollRange
+ "Ok, this is a bit messed up. We need to return the width of the widest item in the list. If we grab every item in the list, it defeats the purpose of LazyListMorph. If we don't, then we don't know the size.
+
+ This is a compromise -- find the widest of the first 30 items, then double it, This width will be updated as new items are installed, so it will always be correct for the visible items. If you know a better way, please chime in."
+
+ | itemsToCheck item index |
+ "Check for a cached value"
+ maxWidth ifNotNil:[^maxWidth].
+
+ "Compute from scratch"
+ itemsToCheck := 30 min: (listItems size).
+ maxWidth := 0.
+
+ "Check the first few items to get a representative sample of the rest of the list."
+ index := 1.
+ [index < itemsToCheck] whileTrue:
+ [ item := self getListItem: index. "Be careful not to actually install this item"
+ maxWidth := maxWidth max: (self widthToDisplayItem: item asStringOrText contents).
+ index:= index + 1.
+ ].
+
+ "Add some initial fudge if we didn't check all the items."
+ (itemsToCheck < listItems size) ifTrue:[maxWidth := maxWidth*2].
+
+ ^maxWidth
+ !
Item was added:
+ ----- Method: LazyListMorph>>highlightHoverRow:on: (in category 'drawing') -----
+ highlightHoverRow: row on: aCanvas
+ | drawBounds |
+ drawBounds := self drawBoundsForRow: row.
+ drawBounds := drawBounds intersect: self bounds.
+ aCanvas fillRectangle: drawBounds color: (self class listSelectionColor darker alpha: 0.3).!
Item was added:
+ ----- Method: LazyListMorph>>highlightPotentialDropRow:on: (in category 'drawing') -----
+ highlightPotentialDropRow: row on: aCanvas
+ | drawBounds |
+ drawBounds := self drawBoundsForRow: row.
+ drawBounds := drawBounds intersect: self bounds.
+ aCanvas frameRectangle: drawBounds color: Color blue!
Item was added:
+ ----- Method: LazyListMorph>>icon: (in category 'accessing') -----
+ icon: row
+ | icon |
+ listIcons ifNil: [listIcons := Array new: listItems size].
+ row <= listIcons size ifFalse: [^ listSource iconAt: row].
+ icon := listIcons at: row.
+ icon ifNil:
+ [icon := listSource iconAt: row.
+ listIcons at: row put: icon].
+ ^ icon!
Item was added:
+ ----- Method: LazyListMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ self color: Color black.
+ font := Preferences standardListFont.
+ listItems := #().
+ listIcons := #().
+ selectedRow := nil.
+ selectedRows := PluggableSet integerSet.
+ preSelectedRow := nil.
+ self adjustHeight.!
Item was added:
+ ----- Method: LazyListMorph>>item: (in category 'list access') -----
+ item: index
+ "return the index-th item, using the 'listItems' cache"
+ | newItem itemWidth |
+ (index between: 1 and: listItems size)
+ ifFalse: [ "there should have been an update, but there wasn't!!" ^self getListItem: index].
+ (listItems at: index) ifNil: [
+ newItem := self getListItem: index.
+ "Update the width cache."
+ maxWidth ifNotNil:[
+ itemWidth := self widthToDisplayItem: newItem asStringOrText contents.
+ itemWidth > maxWidth ifTrue:[
+ maxWidth := itemWidth.
+ self adjustWidth.
+ ]].
+ listItems at: index put: newItem ].
+ ^listItems at: index!
Item was added:
+ ----- Method: LazyListMorph>>listChanged (in category 'list management') -----
+ listChanged
+ "set newList to be the list of strings to display"
+ | size |
+ size := self getListSize.
+ listItems := Array new: size withAll: nil.
+ listIcons := Array new: size withAll: nil.
+ maxWidth := nil.
+ selectedRow := nil.
+ selectedRows := PluggableSet integerSet.
+ preSelectedRow := nil.
+ self adjustHeight.
+ self adjustWidth.
+ self changed.
+ !
Item was added:
+ ----- Method: LazyListMorph>>listSource: (in category 'initialization') -----
+ listSource: aListSource
+ "set the source of list items -- typically a PluggableListMorph"
+ listSource := aListSource.
+ self listChanged!
Item was added:
+ ----- Method: LazyListMorph>>preSelectedRow: (in category 'list management') -----
+ preSelectedRow: index
+ " Show the user which row is about to become selected, thus providing feedback if there is a delay between the selection gesture and the actual selection of the row. "
+
+ preSelectedRow := index.
+ self changed.!
Item was added:
+ ----- Method: LazyListMorph>>rowAtLocation: (in category 'list management') -----
+ rowAtLocation: aPoint
+ "return the number of the row at aPoint"
+ | y |
+ y := aPoint y.
+ y < self top ifTrue: [ ^ 1 min: listItems size ].
+ ^((y - self top // (font height)) + 1) min: listItems size max: 0!
Item was added:
+ ----- Method: LazyListMorph>>rowChanged: (in category 'updating') -----
+ rowChanged: anInteger
+
+ self invalidRect: (self drawBoundsForRow: anInteger).!
Item was added:
+ ----- Method: LazyListMorph>>selectRow: (in category 'list management') -----
+ selectRow: index
+ " Select the index-th row. Clear the pre selection highlight. "
+ selectedRows add: index.
+ preSelectedRow := nil.
+ self changed.!
Item was added:
+ ----- Method: LazyListMorph>>selectedRow (in category 'list management') -----
+ selectedRow
+ "return the currently selected row, or nil if none is selected"
+ ^selectedRow!
Item was added:
+ ----- Method: LazyListMorph>>selectedRow: (in category 'list management') -----
+ selectedRow: index
+ " Select the index-th row. Clear the pre selection highlight. If nil, remove the current selection. "
+ selectedRow := index.
+ preSelectedRow := nil.
+ self changed.!
Item was added:
+ ----- Method: LazyListMorph>>topVisibleRowForCanvas: (in category 'drawing') -----
+ topVisibleRowForCanvas: aCanvas
+ "return the top visible row in aCanvas's clip rectangle"
+ ^self rowAtLocation: aCanvas clipRect topLeft.
+ !
Item was added:
+ ----- Method: LazyListMorph>>unselectRow: (in category 'list management') -----
+ unselectRow: index
+ "unselect the index-th row"
+ selectedRows remove: index ifAbsent: [].
+ preSelectedRow := nil.
+ self changed.!
Item was added:
+ ----- Method: LazyListMorph>>userString (in category 'accessing') -----
+ userString
+ "Do I have a text string to be searched on?"
+
+ ^ String streamContents: [:strm |
+ 1 to: self getListSize do: [:i |
+ "must use asStringOrText because that's what the drawing uses, too"
+ strm nextPutAll: (self getListItem: i) asStringOrText; cr]]!
Item was added:
+ ----- Method: LazyListMorph>>widthToDisplayItem: (in category 'scroll range') -----
+ widthToDisplayItem: item
+ ^ self font widthOfStringOrText: item asStringOrText!
Item was added:
+ BorderGripMorph subclass: #LeftGripMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: LeftGripMorph>>apply: (in category 'target resize') -----
+ apply: delta
+ | oldBounds |
+ oldBounds := target bounds.
+ target
+ bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner)!
Item was added:
+ ----- Method: LeftGripMorph>>defaultWidth (in category 'initialize') -----
+ defaultWidth
+
+ ^ 5!
Item was added:
+ ----- Method: LeftGripMorph>>gripLayoutFrame (in category 'accessing') -----
+ gripLayoutFrame
+ ^ LayoutFrame
+ fractions: (0 @ 0 corner: 0 @ 1)
+ offsets: (0 @ 0 negated corner: self defaultWidth @ 0)!
Item was added:
+ ----- Method: LeftGripMorph>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ self vResizing: #spaceFill.!
Item was added:
+ ----- Method: LeftGripMorph>>ptName (in category 'accessing') -----
+ ptName
+ ^#left!
Item was added:
+ ----- Method: LeftGripMorph>>resizeCursor (in category 'accessing') -----
+ resizeCursor
+
+ ^ Cursor resizeForEdge: #left!
Item was added:
+ PolygonMorph subclass: #LineMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !LineMorph commentStamp: '<historical>' prior: 0!
+ This is really only a shell for creating single-segment straight-line Shapes.!
Item was added:
+ ----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Line'
+ categories: #('Graphics' 'Basic')
+ documentation: 'A straight line. Shift-click to get handles and move the ends.'!
Item was added:
+ ----- Method: LineMorph class>>from:to:color:width: (in category 'instance creation') -----
+ from: startPoint to: endPoint color: lineColor width: lineWidth
+
+ ^ PolygonMorph vertices: {startPoint. endPoint}
+ color: Color black borderWidth: lineWidth borderColor: lineColor!
Item was added:
+ ----- Method: LineMorph class>>new (in category 'instance creation') -----
+ new
+ ^ self from: 0 at 0 to: 50 at 50 color: Color black width: 2!
Item was added:
+ ----- Method: LineMorph class>>newStandAlone (in category 'new-morph participation') -----
+ newStandAlone
+ "Answer a suitable instance for use in a parts bin, for example"
+
+ ^ self new setNameTo: 'Line'!
Item was added:
+ ----- Method: LinedTTCFont>>computeForm: (in category '*Morphic-Multilingual') -----
+ computeForm: char
+
+ | ttGlyph scale |
+
+ char = Character tab ifTrue: [^ super computeForm: char].
+
+ "char = $U ifTrue: [self doOnlyOnce: [self halt]]."
+ scale := self pixelSize asFloat / (ttcDescription ascender - ttcDescription descender).
+ ttGlyph := ttcDescription at: char.
+ ^ ttGlyph asFormWithScale: scale ascender: ttcDescription ascender descender: ttcDescription descender fgColor: foregroundColor bgColor: Color transparent depth: self depth replaceColor: false lineGlyph: lineGlyph lingGlyphWidth: contourWidth emphasis: emphasis!
Item was added:
+ Object subclass: #ListItemWrapper
+ instanceVariableNames: 'item model'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
+
+ !ListItemWrapper commentStamp: '<historical>' prior: 0!
+ Contributed by Bob Arning as part of the ObjectExplorer package.
+ !
Item was added:
+ ----- Method: ListItemWrapper class>>with: (in category 'as yet unclassified') -----
+ with: anObject
+
+ ^self new setItem: anObject!
Item was added:
+ ----- Method: ListItemWrapper class>>with:model: (in category 'as yet unclassified') -----
+ with: anObject model: aModel
+
+ ^self new setItem: anObject model: aModel!
Item was added:
+ ----- Method: ListItemWrapper>>acceptDroppingObject: (in category 'as yet unclassified') -----
+ acceptDroppingObject: anotherItem
+
+ ^item acceptDroppingObject: anotherItem!
Item was added:
+ ----- Method: ListItemWrapper>>asString (in category 'converting') -----
+ asString
+
+ ^item asString!
Item was added:
+ ----- Method: ListItemWrapper>>balloonText (in category 'accessing') -----
+ balloonText
+
+ ^nil!
Item was added:
+ ----- Method: ListItemWrapper>>canBeDragged (in category 'as yet unclassified') -----
+ canBeDragged
+
+ ^true!
Item was added:
+ ----- Method: ListItemWrapper>>contents (in category 'accessing') -----
+ contents
+
+ ^Array new!
Item was added:
+ ----- Method: ListItemWrapper>>handlesMouseOver: (in category 'as yet unclassified') -----
+ handlesMouseOver: evt
+
+ ^false!
Item was added:
+ ----- Method: ListItemWrapper>>hasContents (in category 'accessing') -----
+ hasContents
+
+ ^self contents isEmpty not!
Item was added:
+ ----- Method: ListItemWrapper>>hasEquivalentIn: (in category 'as yet unclassified') -----
+ hasEquivalentIn: aCollection
+
+ ^aCollection anySatisfy: [ :each |
+ each withoutListWrapper = item withoutListWrapper]!
Item was added:
+ ----- Method: ListItemWrapper>>highlightingColor (in category 'accessing') -----
+ highlightingColor
+
+ ^Preferences menuSelectionColor makeForegroundColor!
Item was added:
+ ----- Method: ListItemWrapper>>icon (in category 'accessing') -----
+ icon
+ "Answer a form to be used as icon"
+ ^ nil!
Item was added:
+ ----- Method: ListItemWrapper>>item (in category 'accessing') -----
+ item
+ ^ item!
Item was added:
+ ----- Method: ListItemWrapper>>itemName (in category 'accessing') -----
+ itemName
+
+ ^ self item asString!
Item was added:
+ ----- Method: ListItemWrapper>>model (in category 'accessing') -----
+ model
+ ^ model!
Item was added:
+ ----- Method: ListItemWrapper>>preferredColor (in category 'accessing') -----
+ preferredColor
+ ^ Color black!
Item was added:
+ ----- Method: ListItemWrapper>>sendSettingMessageTo: (in category 'as yet unclassified') -----
+ sendSettingMessageTo: aModel
+
+ aModel
+ perform: (self settingSelector ifNil: [^self])
+ with: self withoutListWrapper
+ !
Item was added:
+ ----- Method: ListItemWrapper>>setItem: (in category 'initialization') -----
+ setItem: anObject
+
+ item ifNotNil: [:obj | obj removeDependent: self].
+ item := anObject.
+ item ifNotNil: [:obj | obj addDependent: self].!
Item was added:
+ ----- Method: ListItemWrapper>>setItem:model: (in category 'initialization') -----
+ setItem: anObject model: aModel
+
+ model := aModel.
+ self setItem: anObject.!
Item was added:
+ ----- Method: ListItemWrapper>>settingSelector (in category 'as yet unclassified') -----
+ settingSelector
+
+ ^nil!
Item was added:
+ ----- Method: ListItemWrapper>>wantsDroppedObject: (in category 'as yet unclassified') -----
+ wantsDroppedObject: anotherItem
+
+ ^false!
Item was added:
+ ----- Method: ListItemWrapper>>withoutListWrapper (in category 'converting') -----
+ withoutListWrapper
+
+ ^item withoutListWrapper!
Item was added:
+ ----- Method: MIDIFileReader class>>playFileNamed: (in category '*Morphic-Sounds') -----
+ playFileNamed: fileName
+
+ ScorePlayerMorph
+ openOn: (self scoreFromFileNamed: fileName)
+ title: (FileDirectory localNameFor: fileName).
+ !
Item was added:
+ ----- Method: MIDIFileReader class>>playStream: (in category '*Morphic-Sounds') -----
+ playStream: binaryStream
+
+ ScorePlayerMorph
+ openOn: (self scoreFromStream: binaryStream)
+ title: 'a MIDI stream'
+ !
Item was added:
+ ----- Method: MIDIFileReader class>>playURLNamed: (in category '*Morphic-Sounds') -----
+ playURLNamed: urlString
+
+ | titleString |
+ titleString := urlString
+ copyFrom: (urlString findLast: [:c | c=$/]) + 1
+ to: urlString size.
+ ScorePlayerMorph
+ openOn: (self scoreFromURL: urlString)
+ title: titleString.
+ !
Item was added:
+ MenuMorph subclass: #MVCMenuMorph
+ instanceVariableNames: 'done mvcSelection'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus'!
+
+ !MVCMenuMorph commentStamp: '<historical>' prior: 0!
+ I simulate the MVC menu classes PopUpMenu, SelectionMenu, and CustomMenu when running in a Morphic world. I am also used to implement Utilities>informUser:during:.!
Item was added:
+ ----- Method: MVCMenuMorph class>>from:title: (in category 'instance creation') -----
+ from: aPopupMenu title: titleStringOrNil
+ "Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world."
+
+ | menu items lines selections labelString j |
+ menu := self new.
+ titleStringOrNil ifNotNil: [
+ titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]].
+ labelString := aPopupMenu labelString.
+ items := labelString asString lines.
+ labelString isText ifTrue:
+ ["Pass along text emphasis if present"
+ j := 1.
+ items := items collect:
+ [:item | | emphasis |
+ j := labelString asString findString: item startingAt: j.
+ emphasis := TextEmphasis new emphasisCode: (labelString emphasisAt: j).
+ item asText addAttribute: emphasis]].
+ lines := aPopupMenu lineArray.
+ lines ifNil: [lines := #()].
+ menu cancelValue: 0.
+ menu defaultTarget: menu.
+ selections := (1 to: items size) asArray.
+ 1 to: items size do: [:i |
+ menu add: (items at: i) selector: #selectMVCItem: argument: (selections at: i).
+ (lines includes: i) ifTrue: [menu addLine]].
+ ^ menu
+ !
Item was added:
+ ----- Method: MVCMenuMorph>>cancelValue: (in category 'private') -----
+ cancelValue: selectionOrNil
+ "Set the value to be returned if the user cancels without making a selection."
+
+ mvcSelection := selectionOrNil.
+ !
Item was added:
+ ----- Method: MVCMenuMorph>>displayAt:during: (in category 'invoking') -----
+ displayAt: aPoint during: aBlock
+ "Add this menu to the Morphic world during the execution of the given block."
+
+ Smalltalk isMorphic ifFalse: [^ self].
+
+ ActiveWorld addMorph: self centeredNear: aPoint.
+ self world displayWorld. "show myself"
+ aBlock value.
+ self delete!
Item was added:
+ ----- Method: MVCMenuMorph>>informUserAt:during: (in category 'invoking') -----
+ informUserAt: aPoint during: aBlock
+ "Add this menu to the Morphic world during the execution of the given block."
+
+ | title w |
+ Smalltalk isMorphic ifFalse: [^ self].
+
+ title := self allMorphs detect: [ :ea | ea hasProperty: #titleString ].
+ title := title submorphs first.
+ self visible: false.
+ w := ActiveWorld.
+ aBlock value:[:string|
+ self visible ifFalse:[
+ w addMorph: self centeredNear: aPoint.
+ self visible: true].
+ title contents: string.
+ self setConstrainedPosition: Sensor cursorPoint hangOut: false.
+ self changed.
+ w displayWorld "show myself"
+ ].
+ self delete.
+ w displayWorld!
Item was added:
+ ----- Method: MVCMenuMorph>>initialize (in category 'initializing') -----
+ initialize
+ super initialize.
+ self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber
+ !
Item was added:
+ ----- Method: MVCMenuMorph>>invokeAt:in: (in category 'invoking') -----
+ invokeAt: aPoint in: aWorld
+ "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu."
+ "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."
+
+ ^ self invokeAt: aPoint in: aWorld allowKeyboard: Preferences menuKeyboardControl!
Item was added:
+ ----- Method: MVCMenuMorph>>invokeAt:in:allowKeyboard: (in category 'invoking') -----
+ invokeAt: aPoint in: aWorld allowKeyboard: aBoolean
+ "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu."
+ "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."
+ | w originalFocusHolder |
+ self flag: #bob. "is <aPoint> global or local?"
+ self flag: #arNote. "<aPoint> is local to aWorld"
+ originalFocusHolder := aWorld primaryHand keyboardFocus.
+ self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean.
+ done := false.
+ w := aWorld outermostWorldMorph. "containing hand"
+ [self isInWorld & done not] whileTrue: [w doOneSubCycle].
+ self delete.
+ originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder].
+ ^ mvcSelection
+ !
Item was added:
+ ----- Method: MVCMenuMorph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+ ^self valueOfProperty: #morphicLayerNumber ifAbsent: [10].
+ !
Item was added:
+ ----- Method: MVCMenuMorph>>selectMVCItem: (in category 'private') -----
+ selectMVCItem: item
+ "Called by the MenuItemMorph that the user selects.
+ Record the selection and set the done flag to end this interaction."
+
+ mvcSelection := item.
+ done := true.
+ !
Item was added:
+ ----- Method: MailComposition>>addAttachment (in category '*Morphic-Support') -----
+ addAttachment
+ | file fileResult fileName |
+ textEditor
+ ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]].
+
+ (fileResult := StandardFileMenu oldFile)
+ ifNotNil:
+ [fileName := fileResult directory fullNameFor: fileResult name.
+ file := FileStream readOnlyFileNamed: fileName.
+ file ifNotNil:
+ [file binary.
+ self messageText:
+ ((MailMessage from: self messageText asString)
+ addAttachmentFrom: file withName: fileResult name; text).
+ file close]] !
Item was added:
+ ----- Method: MailComposition>>morphicOpen (in category '*Morphic-Support') -----
+ morphicOpen
+ "open an interface for sending a mail message with the given initial
+ text "
+ | textMorph buttonsList sendButton attachmentButton |
+ morphicWindow := SystemWindow labelled: 'Mister Postman'.
+ morphicWindow model: self.
+ textEditor := textMorph := PluggableTextMorph
+ on: self
+ text: #messageText
+ accept: #messageText:
+ readSelection: nil
+ menu: #menuGet:shifted:.
+ morphicWindow addMorph: textMorph frame: (0 @ 0.1 corner: 1 @ 1).
+ buttonsList := AlignmentMorph newRow.
+ sendButton := PluggableButtonMorph
+ on: self
+ getState: nil
+ action: #submit.
+ sendButton
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ label: 'send message';
+ setBalloonText: 'Accept any unaccepted edits and add this to the queue of messages to be sent';
+ onColor: Color white offColor: Color white.
+ buttonsList addMorphBack: sendButton.
+
+ attachmentButton := PluggableButtonMorph
+ on: self
+ getState: nil
+ action: #addAttachment.
+ attachmentButton
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ label: 'add attachment';
+ setBalloonText: 'Send a file with the message';
+ onColor: Color white offColor: Color white.
+ buttonsList addMorphBack: attachmentButton.
+
+ morphicWindow addMorph: buttonsList frame: (0 @ 0 extent: 1 @ 0.1).
+ morphicWindow openInWorld!
Item was added:
+ Morph subclass: #MatrixTransformMorph
+ instanceVariableNames: 'transform'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Balloon'!
+
+ !MatrixTransformMorph commentStamp: '<historical>' prior: 0!
+ MatrixTransformMorph is similar to TransformMorph but uses a MatrixTransform2x3 instead of a MorphicTransform. It is used by clients who want use the BalloonEngine for vector-based scaling instead of the standard WarpBlt pixel-based mechanism.!
Item was added:
+ ----- Method: MatrixTransformMorph>>addFlexShell (in category 'rotate scale and flex') -----
+ addFlexShell
+ "No flex shell necessary"
+ self lastRotationDegrees: 0.0.!
Item was added:
+ ----- Method: MatrixTransformMorph>>asFlexOf: (in category 'initialize') -----
+ asFlexOf: aMorph
+ "Initialize me with position and bounds of aMorph,
+ and with an offset that provides centered rotation."
+ self addMorph: aMorph.
+ self setRotationCenterFrom: aMorph center .
+ self lastRotationDegrees: 0.0.
+ self computeBounds!
Item was added:
+ ----- Method: MatrixTransformMorph>>balloonHelpTextForHandle: (in category 'halos and balloon help') -----
+ balloonHelpTextForHandle: aHandle
+ aHandle eventHandler firstMouseSelector == #changeRotationCenter:with:
+ ifTrue:[^'set center of rotation'].
+ ^super balloonHelpTextForHandle: aHandle!
Item was added:
+ ----- Method: MatrixTransformMorph>>boundsChangedFrom:to: (in category 'geometry') -----
+ boundsChangedFrom: oldBounds to: newBounds
+ oldBounds extent = newBounds extent ifFalse:[
+ transform := transform composedWithGlobal:
+ (MatrixTransform2x3 withOffset: oldBounds origin negated).
+ transform := transform composedWithGlobal:
+ (MatrixTransform2x3 withScale: newBounds extent / oldBounds extent).
+ transform := transform composedWithGlobal:
+ (MatrixTransform2x3 withOffset: newBounds origin).
+ ].
+ transform offset: transform offset + (newBounds origin - oldBounds origin)!
Item was added:
+ ----- Method: MatrixTransformMorph>>changeRotationCenter:with: (in category 'flexing') -----
+ changeRotationCenter: evt with: rotHandle
+ | pos |
+ pos := evt cursorPoint.
+ rotHandle referencePosition: pos.
+ self referencePosition: pos.!
Item was added:
+ ----- Method: MatrixTransformMorph>>changed (in category 'updating') -----
+ changed
+ ^self invalidRect: (self fullBounds insetBy: -1)!
Item was added:
+ ----- Method: MatrixTransformMorph>>computeBounds (in category 'geometry') -----
+ computeBounds
+ | box |
+ (submorphs isNil or:[submorphs isEmpty]) ifTrue:[^self].
+ box := nil.
+ submorphs do:[:m| | subBounds |
+ subBounds := self transform localBoundsToGlobal: m bounds.
+ box
+ ifNil:[box := subBounds]
+ ifNotNil:[box := box quickMerge: subBounds].
+ ].
+ box ifNil:[box := 0 at 0 corner: 20 at 20].
+ fullBounds := bounds := box!
Item was added:
+ ----- Method: MatrixTransformMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+ self visible ifFalse:[^false].
+ (bounds containsPoint: aPoint) ifFalse: [^ false].
+ self hasSubmorphs
+ ifTrue: [self submorphsDo:
+ [:m | (m fullContainsPoint: (self transform globalPointToLocal: aPoint))
+ ifTrue: [^ true]].
+ ^ false]
+ ifFalse: [^ true]!
Item was added:
+ ----- Method: MatrixTransformMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas!
Item was added:
+ ----- Method: MatrixTransformMorph>>drawSubmorphsOn: (in category 'drawing') -----
+ drawSubmorphsOn: aCanvas
+ aCanvas asBalloonCanvas transformBy: self transform
+ during:[:myCanvas| super drawSubmorphsOn: myCanvas].!
Item was added:
+ ----- Method: MatrixTransformMorph>>extent: (in category 'geometry') -----
+ extent: extent
+ self handleBoundsChange:[super extent: extent]!
Item was added:
+ ----- Method: MatrixTransformMorph>>fullBounds (in category 'layout') -----
+ fullBounds
+
+ fullBounds ifNil:[
+ fullBounds := self bounds.
+ submorphs do:[:m| | subBounds |
+ subBounds := (self transform localBoundsToGlobal: m fullBounds).
+ fullBounds := fullBounds quickMerge: subBounds.
+ ].
+ ].
+ ^fullBounds!
Item was added:
+ ----- Method: MatrixTransformMorph>>fullContainsPoint: (in category 'geometry testing') -----
+ fullContainsPoint: aPoint
+ | p |
+ self visible ifFalse:[^false].
+ (self fullBounds containsPoint: aPoint) ifFalse:[^false].
+ (self containsPoint: aPoint) ifTrue:[^true].
+ p := self transform globalPointToLocal: aPoint.
+ submorphs do:[:m|
+ (m fullContainsPoint: p) ifTrue:[^true].
+ ].
+ ^false!
Item was added:
+ ----- Method: MatrixTransformMorph>>handleBoundsChange: (in category 'geometry') -----
+ handleBoundsChange: aBlock
+ | oldBounds newBounds |
+ oldBounds := bounds.
+ aBlock value.
+ newBounds := bounds.
+ self boundsChangedFrom: oldBounds to: newBounds.!
Item was added:
+ ----- Method: MatrixTransformMorph>>hasNoScaleOrRotation (in category 'flexing') -----
+ hasNoScaleOrRotation
+ ^true!
Item was added:
+ ----- Method: MatrixTransformMorph>>heading (in category 'geometry eToy') -----
+ heading
+ "Return the receiver's heading (in eToy terms)"
+ ^ self forwardDirection + self innerAngle!
Item was added:
+ ----- Method: MatrixTransformMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ transform := MatrixTransform2x3 identity!
Item was added:
+ ----- Method: MatrixTransformMorph>>innerAngle (in category 'flexing') -----
+ innerAngle
+ ^ (self transform a11 @ self transform a21) degrees!
Item was added:
+ ----- Method: MatrixTransformMorph>>invalidRect:from: (in category 'change reporting') -----
+ invalidRect: rect from: aMorph
+ aMorph == self
+ ifTrue:[super invalidRect: rect from: self]
+ ifFalse:[super invalidRect: (self transform localBoundsToGlobal: rect) from: aMorph].!
Item was added:
+ ----- Method: MatrixTransformMorph>>lastRotationDegrees (in category 'flexing') -----
+ lastRotationDegrees
+ ^(self valueOfProperty: #lastRotationDegrees) ifNil:[0.0].!
Item was added:
+ ----- Method: MatrixTransformMorph>>lastRotationDegrees: (in category 'flexing') -----
+ lastRotationDegrees: deg
+ deg = 0.0
+ ifTrue:[self removeProperty: #lastRotationDegrees]
+ ifFalse:[self setProperty: #lastRotationDegrees toValue: deg]!
Item was added:
+ ----- Method: MatrixTransformMorph>>privateFullMoveBy: (in category 'private') -----
+ privateFullMoveBy: delta
+ self privateMoveBy: delta.
+ transform offset: transform offset + delta.!
Item was added:
+ ----- Method: MatrixTransformMorph>>removeFlexShell (in category 'flexing') -----
+ removeFlexShell
+ "Do nothing"!
Item was added:
+ ----- Method: MatrixTransformMorph>>rotateBy: (in category 'flexing') -----
+ rotateBy: delta
+ | pt m |
+ delta = 0.0 ifTrue:[^self].
+ self changed.
+ pt := self transformFromWorld globalPointToLocal: self referencePosition.
+ m := MatrixTransform2x3 withOffset: pt.
+ m := m composedWithLocal: (MatrixTransform2x3 withAngle: delta).
+ m := m composedWithLocal: (MatrixTransform2x3 withOffset: pt negated).
+ self transform: (transform composedWithLocal: m).
+ self changed.!
Item was added:
+ ----- Method: MatrixTransformMorph>>rotationCenter (in category 'geometry eToy') -----
+ rotationCenter
+ | pt |
+ pt := self transform localPointToGlobal: super rotationCenter.
+ ^pt - bounds origin / bounds extent asFloatPoint!
Item was added:
+ ----- Method: MatrixTransformMorph>>rotationCenter: (in category 'geometry eToy') -----
+ rotationCenter: aPoint
+ super rotationCenter: (self transform globalPointToLocal: bounds origin + (bounds extent * aPoint))!
Item was added:
+ ----- Method: MatrixTransformMorph>>rotationDegrees: (in category 'flexing') -----
+ rotationDegrees: degrees
+ | last delta |
+ last := self lastRotationDegrees.
+ delta := degrees - last.
+ self rotateBy: delta.
+ self lastRotationDegrees: degrees.!
Item was added:
+ ----- Method: MatrixTransformMorph>>setDirectionFrom: (in category 'geometry eToy') -----
+ setDirectionFrom: aPoint
+ | delta degrees |
+ delta := (self transformFromWorld globalPointToLocal: aPoint) - super rotationCenter.
+ degrees := delta degrees + 90.0.
+ self forwardDirection: (degrees \\ 360) rounded.
+ !
Item was added:
+ ----- Method: MatrixTransformMorph>>setRotationCenterFrom: (in category 'menus') -----
+ setRotationCenterFrom: aPoint
+
+ super setRotationCenterFrom: (self transformFromWorld localPointToGlobal: aPoint)
+ !
Item was added:
+ ----- Method: MatrixTransformMorph>>transform (in category 'flexing') -----
+ transform
+ ^ transform ifNil: [MatrixTransform2x3 identity]!
Item was added:
+ ----- Method: MatrixTransformMorph>>transform: (in category 'accessing') -----
+ transform: aMatrixTransform
+ transform := aMatrixTransform.
+ self computeBounds.!
Item was added:
+ ----- Method: MatrixTransformMorph>>transformFrom: (in category 'event handling') -----
+ transformFrom: uberMorph
+ (owner isNil or:[self == uberMorph]) ifTrue:[^self transform].
+ ^(owner transformFrom: uberMorph) asMatrixTransform2x3 composedWithLocal: self transform!
Item was added:
+ ----- Method: MatrixTransformMorph>>transformedBy: (in category 'geometry') -----
+ transformedBy: aTransform
+ self transform: (self transform composedWithGlobal: aTransform).!
Item was added:
+ ----- Method: MatrixTransformMorph>>visible: (in category 'drawing') -----
+ visible: aBoolean
+ "set the 'visible' attribute of the receiver to aBoolean"
+ extension ifNil: [aBoolean ifTrue: [^ self]].
+ self assureExtension visible: aBoolean!
Item was added:
+ Object subclass: #MenuIcons
+ instanceVariableNames: ''
+ classVariableNames: 'Icons TranslatedIcons'
+ poolDictionaries: ''
+ category: 'Morphic-Menus'!
+
+ !MenuIcons commentStamp: 'sd 11/9/2003 14:09' prior: 0!
+ I represent a registry for icons. You can see the icons I contain using the following script:
+
+ | dict methods |
+ dict := Dictionary new.
+ methods := MenuIcons class selectors select: [:each | '*Icon' match: each asString].
+ methods do: [:each | dict at: each put: (MenuIcons perform: each)].
+ GraphicalDictionaryMenu openOn: dict withLabel: 'MenuIcons'!
Item was added:
+ ----- Method: MenuIcons class>>backIconContents (in category 'private - icons') -----
+ backIconContents
+ "Private - Method generated with the content of the file /home/dgd/back.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADRElEQVRIie3WW4hVVRgH8N/e+5y56aCizpnR
+ jJzUCNFqLhqEWGlQDz0mGEJBCSL1Ur1YZA9BSIZGZg9dVBoo0B5D6qGwOzVaairZiJiKZ0hs
+ 1NE5c2bm7N3DmXF2zQyO5lv+YbFZa/2/77+/y9prcxNpNFnoHi3/xUU4LtYiszX5WGC/ULsW
+ m69XMLgqo8UzEhtRlVpNJJb62Tc3TnCxnH7bBR65sra0nt8vkC9Ah9Ay7U5d2Z+jUrUaoRqx
+ Hr/qGp9gk0cFPsB0UFfFugUsybH1N7YfS7O7UTE4/u2vgDze02ijXUrRCLFmzwtswwRhwGO3
+ Wb55tcWNzQ75g7+KfNmZtqhEZoyXz2IKlutSIe+LNCnQ7A08NxRVuKHVywvXWG+lDXZ5SRs9
+ A7Qd53g3pSQlG1GboTY7PKojNh/hXBFK+s0oC85XocoOrASzJ6p9+wE7c69I8K7PfKrdgBK4
+ XYNWc+VMFgwGlkgU9Svo06OooOiksw7u3MPrhwySVmVAlTasAAummPzWg16oXWGdD+13fESe
+ ulxSZ5I7zTJHg1tNVxIr6FNQ1KlLuw7fOkJ9dTqHDwWarBJoA7lqPlqiflJO58gGuz78cJZn
+ fxya/ZQRutdQKZY1MKlifGJJzEA/A32UUs+4NDhispVcjtMRdmeU7BBag8iJM5yOmDmPYIwj
+ 2pXn5MGy2LhQl3pJF0O/2CuwBXzfS0cnR7+j9/IoUSWcPnINYuhNcRN/DnXpRFUOoFFNwKYa
+ wgJ1s2mYS1TuLedOceLAsIMwIsoSZEhC4oCBgD70xpzB9ktcGExr4PHhvLVqFPsaM02NeC2L
+ XjKVTJtVdp7vKNfufB1bznO2RLE03lhj5P5ZqBZ3SHyFnFsyrM+SFEaabqrm6CjrY6Mf79tn
+ 7cjOaDVfbA+mmRzyajUVqXpGE3g6NQ88IXZYKFISCUVioUAfetDjolOOKZbpo6HV3WK70SCL
+ F2uZ0V3eOzCFd64cm8/t8/C1hDr29dSqXuwT3AfuyjIvy66etPVT9tp2YwShWRZvYu0ouydd
+ MG8oVePFyOspjbxY3m4znMD9hm/90xJPOuzYmLZj4Oq/GENYZKqS1QKxPlsdNMqX4Sb+D/gb
+ LOgMCUjhiw4AAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>base64ContentsOfFileNamed: (in category 'icons creation') -----
+ base64ContentsOfFileNamed: aString
+ "Private - convenient method"
+
+ | file base64Contents |
+ file := FileStream readOnlyFileNamed: aString.
+ base64Contents := (Base64MimeConverter mimeEncode: file binary) contents.
+ file close.
+ ^ base64Contents!
Item was added:
+ ----- Method: MenuIcons class>>blankIcon (in category 'accessing - icons') -----
+ blankIcon
+ ^self blankIconOfWidth: 16.
+ !
Item was added:
+ ----- Method: MenuIcons class>>blankIconOfWidth: (in category 'private - icons') -----
+ blankIconOfWidth: aNumber
+ ^ Icons
+ at: ('blankIcon-' , aNumber asString) asSymbol
+ ifAbsentPut: [Form extent: aNumber @ 1 depth:8]!
Item was added:
+ ----- Method: MenuIcons class>>configurationIcon (in category 'private - icons') -----
+ configurationIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'configuration'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self configurationIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>configurationIconContents (in category 'private - icons') -----
+ configurationIconContents
+ "Private - Method generated with the content of the file /home/dgd/configuration.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAF30lEQVRIia2WfWyV1R3HP8/L7X3p09tCZRWx
+ oE2x4Es2CIMmjiVjtKSQ4R9ONzbrtgQMakI3EoWiA3QMssTF1U2zGhZsQ5buzQmdZJszULAd
+ ULTUYPClaKm7VLkwS2/v6/M897c/zn3u7a2VSNwvObnnOfec8znf3/n9zjkGn99M4HFgF3Az
+ oAGjgHMNc3xuuw04BciSJV+TjRs3S3X1TQKkgCPADuDrgP+LggxgC5AKBkvl2Wd/Lx9/nJHh
+ 4bScPBmX/ftPyKZNe6S29naxrLAASeBVlCfuBHxTJzSvArsF6ADqGxvvoq3teSorZxKNOsRi
+ 2XyngwdfYHj4HebOnc+OHXsDn3wSXXH6dO+KgYFeRkfPJ4Be4HCunNSmAWlAC7C7oqIy2NTU
+ SFNTE5HIKAMDQyxYsJRly77JkSMHaGtrJZNJsWrVvWzd+muCQatoov7+wzz66HdIJuNe0+yp
+ sBqgB5CHH26V4eGYjIyMyd69f5HFi5eLrusC5IthmLJu3SY5evSyHD8eLypbtjwjgUBI0HVB
+ 17wx+RVpwIPAxMKFX5aenrckGrXlwoWMDAwk8pM89dSfJByeIYBoWn4S8fuDUl+/Ulpa9kh7
+ +yuyfPka9V+FJTz3YyHoFyCb4xACXgGkrKxcurr+JZFIQs6dS8uJEwrU1zcu69c/JrpuCCBr
+ 1nxfDh36QHbt6pCGhnskFLImwQOqfus84W97hFPtgmkIEPOUVQEfTfZrIBCkrm4R9fUrqav7
+ Cp2dv+T06V6CwVIeeeRXrF79vaJ9iMfH2blzA6+99jIiApVh6N4DJSaIwFc3kmPMNoE4QMua
+ Ju667VYOHj/Bb4/1ZgcH+/TBwT7lb03Dssppbt7M0qUrimBDQ2fYvv2HvP/+WQUwDLCCqg5g
+ u17XmFfRAfnp3XeL+9KL4rzwOxm7eY50z75O7ijxSVlhw/OltvZ2aW7+iWzY8Lj4fH7VXjVD
+ 6GwVZlUIc65TrjzVLvxxhzfuDVB5mDUgk3adEoU3CGgaDcEAu/VxYlnhyZnllOkaf0+k6Emm
+ ZWjojDY0dKYgc+kC2L0BKizwmeDkVP2zH36+v0ihCWBoWqoA1PPzOKJ+bzIN7rVCPBi2SIlo
+ R5Np9sXi/DWeVLDftBTGlZgwnoYnOqC7b7L3Jzx3YkIqbefOYKMA9LxfOmkRAU2jMRRgnRVS
+ DZXlRYskm4WxuIKV+GDj2iKFCqiRito2H7kuohsFoCiJljbdgeR1yh1zItD5D/gwqqC1c2D/
+ NmhYUqRQuRQtOWE7HE6m0W2bnktj3GMFsfMKrwZ04dIV2L4PTp7NecmAzlalcCjyaYUGJH2u
+ y1zTIKvrtI9PsPJClHczCnnOdpDPAl4cg+8+qWAVFtRVq+wuyV0Umfx1WdhDQ9OStuNwZ8DP
+ t8MWe2fNZGUwkL9Zf3Dxv9wyMkrr5Su8ns4UA8+eh7EJWLYQurbDl2YUohTAyQMnRynJtKs6
+ +TSN+8Kl3FcWYv7IKB86Lov8JQykMzx9JcbTV2LU+EwWewqCfvhREzQ3gKaptAC1t4YO/e8U
+ KTRzMhMpZ9JLQTfALbjxyA2ziDguXRMJuiYSvGs7DHtRPf9GuL+xMNY7YVIZaPszvHgM1FPk
+ aN6lpqYnku5koAoSR8DUwK9p1PhMts0I82b19fx7ThWrQwHVd2o8ecBNz3iwY8Bi4EweGHfd
+ 6AfnR2g/cIALkUg+r1wES9OZaov8Pu4vK1Uf2SnhlEhDuBQGzwG0ASuYdDmYANFstoPx8ZqH
+ 9nWsemhfh77AZ9oPhC2fLRC6WkqASgvPXn0Djr0JaTsOrAe6pnb3lt8PrEY9/372tu1c3Hx5
+ jJhINpkV6U2lPxvoZFXSt3fD1uchbb8H1E8Hu5oZwFrgZdQJJ/NMI/GLynKJzLtBUjU3yh+q
+ Kl1AmFclfGORdyO8BJRfC2g6qwaeAP4DiAHO2lAwvrm8zKZwZbnANj4dQl/IDOBbQDfqte3B
+ LgEN/0/QdFYN7AQOAXOvZeD/AIXZmm50KVY/AAAAAElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>confirmIcon (in category 'private - icons') -----
+ confirmIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'confirm'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self confirmIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>confirmIconContents (in category 'private - icons') -----
+ confirmIconContents
+ "Private - Method generated with the content of the file /home/dgd/confirm.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACsElEQVR4nK3WvW8URxjH8c+CDxtsYg6FCJDy
+ IqUIWKAUiCJFWuiRIqWCKn9AynRJnS4VShEpEimSBlGkiKBAGIkUWIoUBVtC4IvBb2BsH8fd
+ +fD5NsWM7VO43bXPPNJoZnafme/MPL95oT8r4RCS3TbcTYNSibEynw1xusXiKyp1FvAQT5G+
+ LeB7H/HdCFdwcLNRStri1gK/1HiMP7G+V+ChT7hd4vwRXMB+vIxpEs+pzvB1jakIzZzp/iLa
+ x3w/yKWL+DECP8cpLGEULxgqcXaZ8ZR6HEtfwOQkv51h8CqGun68E6ETgoJmKadM1HkmxLWn
+ 7cujneCDhMNfZjiOYgzlWB/mUxzO6zMXOBpjfDTHp2xbJSlN1PoGTlFJmZ3K8XmCf2O5yTRW
+ +gZCm2s/d3XabY9wM+YbTC5yL8N1ywpVWma8zRe/8+5BDGAef+BbVNBhvca948yfYOFZUGpP
+ y9uH+87yVco3+HDT+f8bLMVGHHmCOpenuY5XvTodyKKdY6jF1UFB/idj5yuCKgZwTDhQ4Q5W
+ 6cyyJgh4d8AJmmfwPq5FWBXLoWO1MBt/xe8v0WH6dVBqT1guMDLW2nG/JzgSU7fD/TjrFOs8
+ iMVMYJFKmxs5P+eF9VuO9Qb/hExms1xgQrOd839T/5vAaphh/xs/pZEHnLMtpA7z9VDMXM5C
+ oIIZLgliaduKH3uZIZpZt2kqXAkvYr0V4rdnYCMr+nMBshW/2g4UWghMc5Z0OubLwa+6wqyg
+ 0E7fwDyVzgkbv4X2DpezEIhGqveQl2zHb22HgikEJuGYeuMZ1hH24GSoNle3H06LewLGG/yN
+ Y+MJxvEaq/xQDaC/QzXf8s5SKc0ElzCIAzE1hLVb48ZT7goamimC7QT4K2Yq4VkzkjDSYThh
+ uEO7wk/CZfEgr59u+w8LnvWEFNR9UgAAAABJRU5ErkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>createIconMethodsFromDirectory: (in category 'icons creation') -----
+ createIconMethodsFromDirectory: directory
+ "
+ Preferences disable: #showWorldMainDockingBar.
+ MenuIcons createIconMethodsFromDirectory: '/home/dgd/'.
+ Preferences enable: #showWorldMainDockingBar.
+ "
+ | iconContentsSourceTemplate iconSourceTemplate normalSize smallSize |
+ iconContentsSourceTemplate := '{1}IconContents
+ "Private - Method generated with the content of the file {2}"
+ ^ ''{3}'''.
+ iconSourceTemplate := '{1}Icon
+ "Private - Generated method"
+ ^ Icons
+ at: #''{1}''
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self {1}IconContents readStream) ].'.
+ ""
+ normalSize := #('back' 'configuration' 'confirm' 'forward' 'fullScreen' 'help' 'home' 'jump' 'objectCatalog' 'objects' 'paint' 'project' 'publish' 'squeak' 'volume' 'window' 'open' 'loadProject' ).
+ smallSize := #('smallExport' 'smallAuthoringTools' 'smallDebug' 'smallBack' 'smallCancel' 'smallConfiguration' 'smallCopy' 'smallCut' 'smallDelete' 'smallDoIt' 'smallExpert' 'smallFind' 'smallForward' 'smallFullScreen' 'smallHelp' 'smallHome' 'smallInspectIt' 'smallJump' 'smallLanguage' 'smallNew' 'smallObjectCatalog' 'smallObjects' 'smallOk' 'smallOpen' 'smallPaint' 'smallPaste' 'smallPrint' 'smallProject' 'smallPublish' 'smallQuit' 'smallRedo' 'smallRemoteOpen' 'smallSave' 'smallSaveAs' 'smallSelect' 'smallSqueak' 'smallUndo' 'smallUpdate' 'smallVolume' 'smallWindow' 'smallLeftFlush' 'smallCentered' 'smallJustified' 'smallRightFlush' 'smallFonts' 'smallLoadProject' ).
+ normalSize , smallSize
+ do: [:each |
+ | png base64 contentsSelector selector |
+ png := directory , each , '.png'.
+ base64 := self base64ContentsOfFileNamed: png.
+ ""
+ contentsSelector := (each , 'IconContents') asSymbol.
+ ((self respondsTo: contentsSelector)
+ and: [(self perform: contentsSelector)
+ = base64])
+ ifFalse: [| contentsSource |
+ contentsSource := iconContentsSourceTemplate format: {each. png. base64}.
+ self class compile: contentsSource classified: 'private - icons'].
+ ""
+ selector := (each , 'Icon') asSymbol.
+ (self respondsTo: selector)
+ ifFalse: [| source |
+ source := iconSourceTemplate format: {each}.
+ self class compile: source classified: 'private - icons']].
+ ""
+ self initializeIcons!
Item was added:
+ ----- Method: MenuIcons class>>decorateMenu: (in category 'menu decoration') -----
+ decorateMenu: aMenu
+ "decorate aMenu with icons"
+
+ | maxWidth |
+
+ Preferences menuWithIcons ifFalse: [^ self].
+ Preferences tinyDisplay ifTrue:[^ self].
+
+ maxWidth := 0.
+
+ aMenu items do: [:item |
+ item icon isNil ifTrue: [
+ | icon |
+ icon := self iconForMenuItem: item.
+ icon isNil ifFalse: [
+ item icon: icon.
+ maxWidth := maxWidth max: item icon width.
+ ]
+ ]
+ ifFalse: [
+ maxWidth := maxWidth max: item icon width
+ ].
+
+ item hasSubMenu ifTrue: [
+ self decorateMenu: item subMenu.
+ ].
+ ].
+
+ maxWidth isZero ifFalse: [
+ aMenu addBlankIconsIfNecessary: (self blankIconOfWidth: maxWidth).
+ ].
+ !
Item was added:
+ ----- Method: MenuIcons class>>exportAllIconsAsGif (in category 'import/export') -----
+ exportAllIconsAsGif
+ "self exportAllIconsAsGif"
+
+ | sels |
+ sels := self class selectors select: [:each | '*Icon' match: each asString].
+ sels do: [:each | self exportIcon: (MenuIcons perform: each) asGifNamed: each asString].
+ !
Item was added:
+ ----- Method: MenuIcons class>>exportAllIconsAsPNG (in category 'import/export') -----
+ exportAllIconsAsPNG
+ "self exportAllIconsAsPNG"
+
+ | sels |
+ sels := self class selectors select: [:each | '*Icon' match: each asString].
+ sels do: [:each | self exportIcon: (MenuIcons perform: each) asPNGNamed: each asString].
+ !
Item was added:
+ ----- Method: MenuIcons class>>exportIcon:asGifNamed: (in category 'import/export') -----
+ exportIcon: image asGifNamed: aString
+ "self exportIcon: self newIcon asGifNamed: 'newIcon'"
+
+ | writer |
+ writer := GIFReadWriter on: (FileStream newFileNamed: aString, '.gif').
+ [ writer nextPutImage: image]
+ ensure: [writer close]!
Item was added:
+ ----- Method: MenuIcons class>>exportIcon:asPNGNamed: (in category 'import/export') -----
+ exportIcon: image asPNGNamed: aString
+ "self exportIcon: self newIcon asPNGNamed: 'newIcon'"
+
+ | writer |
+ writer := PNGReadWriter on: (FileStream newFileNamed: aString, '.png').
+ [ writer nextPutImage: image]
+ ensure: [writer close]!
Item was added:
+ ----- Method: MenuIcons class>>forwardIconContents (in category 'private - icons') -----
+ forwardIconContents
+ "Private - Method generated with the content of the file /home/dgd/forward.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADXUlEQVRIie3WX2iVZRwH8M97znv2f1o2Fy4r
+ hxMvhhCeTewmJcuEbiLLP0GECoJWEIlYUBoR3QTVhRRIXffvJupiBF4oRCZukq5Na4LhlKnT
+ 6XE7c/P8ebs4O8fNlh3nVdEPHnif5/d8f9/3+33e53le/usRvyv0UknzzDXgQrmQ2IzJkt4V
+ 6BT4xVJfWKa5HFgwI7J27fIOmerQmMBOnfbeGWGrChXmoVZeSlZKjzQisEyznA4s1lhFWwMd
+ Z4tZIh0SNjk8vc03CZO2Yzcap32R6WLLIrYt5sgl3jvOudFiZlBki6O+vxVSsKTNK9iLurLJ
+ 4PkFLKy38YE1Wp5b7uT1P+hJEakV2KDJiAGHpipMSmAIdeoT7GwlGzGaJT2pjeUK49l8Aflw
+ HZtaqI57xwv22OhD33qj+2OZXYe5OFaYF/nIUTtMmB5ot0LeAbB5kSXbn9LqIRXCUksIBZOE
+ Dxl2RJ8T+ktjKy2x1RpN5lh7aY/Lr+6n71qR9EvjXtLjRijnyVKt+TVOOqtNiyc84kENQnGJ
+ Cef7XXLKgGtG9Ruc4u4B3Q7o1mKelxue9ennCYOv76fzMoENqmXxYiDpK6wD7y9ldVPZS3i7
+ mKPe0PAQ6w/etDfwTIjh0qx0mounuXEdAUFAECMekqgkrCCsJFFReA7+/twYMkx9guVz+W7C
+ +rwVIVKlWUGK/vPlSQgC5rfSuGD6fD7H6V76SvXGBPbFBJM2aCpTHhlEEQO/E+X/mhu+TO9B
+ jl3lxETNyG5dTsbdb1xgK+gaY3YdFdXkagiqCWuIVxFWEYbEYhMkUUFFWEntPYWimXHOdHO2
+ l5Fa3koVyQ5aaJteUYCYpAtoKFtdTYwd9zF/sGBtY3OBfOgcuSz5Wbw2zHgEXVilq7B0cUSa
+ jKEdNWURZiL6MqyMCkrTVxhNFZTnZ7MrzWgeesSt0ulKETr1GFviXjUqkJAVE8rLysnIqZKT
+ 0SzmR1SCfXVEIzfxV+t5e4QbEZzCY7oMTKa48+sp6TNsAetn8fi1wvY4Vssnw8Vb41c8rcuZ
+ W+EzIVyNH0r99gT9Oc6XvtavZWx2XHo6+Mwu4DY/iTx6y2hO5E1HfXA76Ex/MTbh50n930RW
+ /xMZM1VYxLZZK2/MQh2+kbuLWv/Hvyj+BJaPHpqZ0oo8AAAAAElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>fullScreenIcon (in category 'private - icons') -----
+ fullScreenIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'fullScreen'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self fullScreenIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>fullScreenIconContents (in category 'private - icons') -----
+ fullScreenIconContents
+ "Private - Method generated with the content of the file /home/dgd/fullScreen.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAHT0lEQVR4nL2WW2xc1RWGv7X3OWcutmfGYzuO
+ 7TjBSYAAgaSQEGhRQVwU2pAgFQFC6iuKhBAvCEWVKtWPBCpVquhTq6pUBURFaVrUBmQuBRWh
+ FJELhIRQGi42SUx8HY9n5lz2Xn3whAZIipCq/tJ6Odr7/Gv9/1rrHPg/QwAeffTRjjiOK2EY
+ DotIRURKqpoXEauqAnhVTY0xdWDBWnu6VqtNDwwMzO3cubPxjQl37959jYgMqepaEbFAoKoB
+ gIio9x5jjPPeZyLi2nc90BSRaRE5HgTBJ0NDQ5/ddddd7jxcS4SqKo888siNwJWLycJlx04e
+ Gwisdb1dy+qD5aHaOe54EUmApqo2gWb7WR2Ycs69H4bh+IMPPjgtIvoVwtHR0c5CoXCtiNzw
+ i5d+dm881Ojr7a8yO1UjPpGkF5cueXfHxjve+i9Je2BBROZVNRYRFZF559wnxpj3G43Gx6Oj
+ o9mZw0GxWOxUVUSkM+5Y7Or+XoH+rirbe2/jqZeeCGtvLHSpqpwr2zYMUFbVsoi0VLWmqlZE
+ Kt77Ffl8/pOHH374aKvVmhgdHfV269atPara49VveKPx2tW5FYEsmjrHakeodvTw8ZsnuoYr
+ K5NKoWKNMREQyBL8OcgDoAOoiogXESMi/UC/MaZz27ZtdeO9j1Q1yLIs1EwlmcmIT6YkpzOG
+ +4e5+d7vhs8cfHLTqfmTZVUtAmWgV1UHgG4RyZ2n6hFVXd2uvt8YU0qSZMCISM5amw+D0LmT
+ mrp5pX4gxtU9B47up2ugg0t/uDb688Fn13/B/CUUgV6gH+g821fv/SKwQlU3GGM6RMSGYRgY
+ wKhqBPCt5VcfKr7ZM71Fr383edU2XcPzyqEXef/Nf1LMdcTn6xoRCUSkDPS1ZeWM5+1ZVmOM
+ zbIsDEQkExHnnOOWy249JiKzgLtk4NLTT4z9dlO9Wu8sz/fMb99y+wdf0zyISNSWcPosUmlX
+ bAETiEjmvY/PyOS9t8YY19PVl+y84f53Do0fWL6sUk7+Mbb34oWFhTBpNUwaxzZzqc3li3Gx
+ q9LsKlUa1d7l9eGRi2a7q1WstYalcfFtBTMRSVQ1DpxzznufGGMUEGst7S3TlQ/zZsvqa6de
+ fO6pVdtv/0Hf+g1XUSqXKZe76SpXSOJW/sg7B8uH336LI+8c5KU//cZJWJwdXHXhB+vWX3m8
+ r6/PAUZEUlVNRaQVGGMyVfUiknrvRUQCIC8ickaq2uxMfscd97BqZO1XZBwcWsH1N99ClrZo
+ LNbs88/t6X3290/27vndYxuGRi45ccWm644PDg6qiGTW2iVC5xze+xRw3vvIGCNnv7RWm8n3
+ 9Q9w9MPj7NULmM1gLhGqkbImDyM5ZV2UYa1h623f56Zbb+bQ/v2Fpx5/fM3zz/xqsG/4osb6
+ jVuOr1y5shUkSVJvF7MgIqW21h1nBjtLU2NEomKxgw/mG7yRNVAEr8J4Aw4AXkNypsymYsh1
+ +ZTVEVy+cSOfjo9z9z33FH6068cXnTq1qjIyMtIyu3btqgGZiEyqqvPeN9udBUCzUbd9y5YD
+ ME9AybQoSYuyaVK2TUrSomSaRMQcXLT8fHoZT8/3YIzBWkso4FwWJEkSdnd3N4yIaBAEc977
+ yXanTra7C4B8scOlSQJAqhkV02J1IeXb3cKNvYZ1nY6KbS0lYmLKJuZwK2QqCwijCO8VkCRN
+ 08WdO3emAYCqzojIbHv5ApwClouIhmHkp6dOKyCha7CuXGKgaFCWPnvdXYLxGXNJhkeWQoXx
+ 1BJFEUmWoiIzaZqehqWdRxRFp9pj8VG7sEkR+UhVW6qKima1+TlK1jFUAPExxrcQHyMas6YI
+ ZRt/HhUbY8URBJZms4W10Wwcx5OfEz7wwAOxc+6kiBwTkRpLq2FeVY+r6qedpe7Fo4cP0dmc
+ J/ANAhpYbbajQZdNWNMB3bZJ5Yy3JiOwAfX6AibM1SYmJv5DCLBr164jwIfe+1eNMVPttZQB
+ 05Vq3/hf9jzNhYOriHydnG8Q0SDSBpFvEmqTauC4oGDpC5d8rlrFinDi0xNokD8+MTEx9QVC
+ EdGHHnrosLX2befcq8BhVa0DfsXKtSde+Oseunv6qMYtCtKgSJMiDQrSIM8ieRbpNC0GcsoF
+ BaFkhcZinddff33OefMeEAPYL2+OsbGxuR07dow75+aBmjGmWe1bPntg32vrioV85zVbvkNO
+ Hfg6VhIio0TiyIknMo7IOMoIeQIO79/P3hdePjgxOffrNE0nz0kIsHfvXjc2NvbZnXfe+a8s
+ y8aByeUrVr33xC8f2/jZqROl9euvoJwrk8cQkpLDEZKRQ8mrUJQ8Rw6+zcz0FH/7+74/TM0u
+ 7gUWOXvAvw6qKvfdd19l38t/vDdNWvevv+Ly4as2b+bKzZsZWbuWIAi+cH7fKy+ze/dPpw4c
+ PXl3Bq8A+o0Iv4w1VYadsk1FthuRS8uVSndPb09XoVg0C7V5NzMzMz0xWfvJbIMngXP9bv5v
+ 0N9PB+exCuDf3d6HA+fU4WgAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>helpIconContents (in category 'private - icons') -----
+ helpIconContents
+ "Private - Method generated with the content of the file /home/dgd/help.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGoklEQVRIicWWeWxU1xWHv/fmzZvF4wF3AION
+ XXuKgSAT0yZhNaRKIMIToARSkbQJIVEw2CW0FRQEIoUUNWpLSCsFlECxUKpilsqCsFjESzFl
+ bGpsEG4DqUjBLRiN8W6P7Vk8753+ETCbIbSq2t8/V/e+q/vdc879HT34H0t5xH2PAbOByTfn
+ UeA68CngB/r+28COzXxt0GNYARDgLBEO08tFot3ANuAdIPxIQNmEejZAriK8BDhNCCkKn13r
+ 4srmSrLqrvJqE2nEo953QD19rKCFUkLXgTnA+YcBVYBzDXwT4SeGsB6T1yIma1eWEFtyXN88
+ bNwzCzLRB4QBHKOXckJYNCXJEW/5aPpo68QTm9AeBNQAFJOAWGifuJMqwDrI49xvt+m+fXv3
+ 2CyqlZ0VL6MMSwKLBSJRJNAEIvyUNt7Xe/ng19vx+XKUtetWZx49dqiyutbx98o8a9ctiICu
+ wF+jii2/n1y7jO01S8nxJLpLn587q7epuUlERM6cOSPzJk2TnvIqCZVXSaS8SowDx6T82RfF
+ 6XRKZWWl3Klfbnk35ozXwpqDKXcAFX/eoC2V+YPe6weeWcqERU/FfTZufEYkEomIiEhnZ1CK
+ i0+I3e6Ro08vktIn5knFs6/I56+ukinDU6SwsFAG0sof5cfcHkeAIcTfOr9yuSvTn+eu/TK6
+ XJw75rHX7lLFX3lKRETa2jrkyJFyKSo6LpmZk2Q6HnkOj8zCI9PxSGKiV5qb2wYEBoNBSU0f
+ HhvscWzrB+a5X/HnufeoZ9/kceAvBZcGT16y+A2ZNjWbUCjMqVM1RKN9tLQ009p6PVqtB3tO
+ 2robTurBi+fjo1esVvOfM2Y8E6upqb3vYbhcLpblrrAYhrkUcJ3Kd+eLQr6uGKuoyaXoD4t4
+ yxanSH39lZt1q5OiouPy4Ye/Mz2eYdfgdj3uVHZ2dlZqqjdYV1d3X5Tlf/SL7kTiB9tf8+e5
+ L/tXOJMAVAUyV1fQk5aWHktLS6ejo4tr1wIAbN26paG1tWkucHogoN/vr+vrCy3ZuHFj8N5v
+ 4VAfSUkpjBo1ai7wZ0xLDoDWZ1A20mXd1Gpq2vz58zlXc562zhAOh4OOjmaVrzByIBA4Vlpa
+ epdJw+EI4XCE5KRkWtuax6jSN9vAeuJkvqtKnVLAb62XtZStjQoHVq6hOGMq7/U4yG4JEYtF
+ Enl4+1OAHaqq9t65eONGCwDd3d3YbHZt6keh68ARDUu2CiTOJ47nvGOwohDs6cWDhZt9UwOy
+ HgJ8B1jc29vrKSsr61/84ot/ICIEAg3YdL27arkjWRFllihGlQo0dWCACABxaSMB8GJFBWw2
+ 2/cHAKlAHvD2ehJYb7hVn8/H7t27CQSa6Orqpr7+Ch2dHUxMsSWYivWoqLIme3v3BQDXHJxm
+ 1DZWzOMnpenAMdmZ8Lh4cciECRNkxIgRoZkzZ751R2rnAFcAeYN4ieCVKF75ZEqOaCji8y2U
+ PXsOSY7vO6I7kVULx+fe11ttKCVX+brE3lwnV3ftk9R4j6xbt04Mw5Bdu3bJkCFDRNM0w+12
+ 96iqagBSwgiJ3oTFXv6hGOVV8umLy2QobklISBbNZpXMrNEdD6rFwnnESbN9jEwdniKrV6+X
+ 9vbOfk+1t7fLjh07ZMOGDeLz+QSQ0yRLVMuQ2HdXiFFeJe3FFXIkeYrsJl2ySBBQJGPMqIIH
+ AVWgJBlNdJsuP3/3fTl4sEQuXaqXWCx2l6EbGxsFkKJpPjH2HZVQeZU0Hi6Tkqzn5QBe+T3p
+ kkqc6DY9CiTcC7LcHAUo9gw2X4pqqsN/usLidLqx6S7q6xsIBnuIxQzC4QhWq87evfvxjh3H
+ 2Kee5GpFNRd+9gHdl68CsI8uziidaBYtxzCMC/cC7/JYbS4Na/5EXk2jXhiJRl3Dhqay4IXv
+ MSP7aRTl9taCggL8pWVsiyVgl9s3LqSLw0ordrv9x6FQ6DcDpfJeYLtuwTv5YxzOePfHXcGu
+ maCQOCyVMRmZjExJxaJaaGtt4+DBT8jDzSTsXCBCMZ18rob6TNNcABx9UO3uUm0uLdU/wHNr
+ bnfx7SGJg0ptcYqhOxHdoYrVoYnVroui6mJHFwVNQDGBQ8Dor2Lc++9xwxojEWitXspoVcGn
+ 0ll95BJLf1FLuhjm+NezePvkdcv+S4FIT1gYjVANHAYuPkpQd6X0bC7rTXgB6FXAA6xFwYuw
+ XCwswOQbirDliZ1kKl+W7d/WfY353OsMBfjWbpr7L7KM2WKyWBTCCvzqyZ387T+B/V/0L+bC
+ W2tds0/6AAAAAElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>homeIcon (in category 'private - icons') -----
+ homeIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'home'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self homeIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>homeIconContents (in category 'private - icons') -----
+ homeIconContents
+ "Private - Method generated with the content of the file /home/dgd/home.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAHDklEQVRIic2WbXBUZxXHf8+9d1+y2WR3w5IQ
+ SOgmgIA2VECgUJuGIoJBapkBHKY6dFp1BMEPLVosY+WLWh2ZdkoHLP3QocN0SkY7CoJFQEBB
+ MLwk2YQEAqFJCCSbl33Nbu7u3nsfP2xgEiq+fHE8M3eemfuce35z7v885zzwPzbxsI1HYYkC
+ 6wQEHuYjwQLSAtLW6Cqg14IOC05ehfC/Bc4HTwbeE7Bm8ee8uPJUslmLWNKgO6RT7LOjCEHG
+ sMhmLSLDBqoqyBqSrGFhGBY+n4OhcLpThZoG6HoocDo4XHAemLtlfRnLljoBOFOf4PSFBC+s
+ 81NeagfAtCRvv9+Pv0jjuWcmAJCIw6kGky8vr+BA3U2OHOs+G4SnyP2JTwPnwB5FsKmsxElh
+ YW4rPmwSiZmUl9pRVXA5FfKcKh3dOjMCTtau9FHitxEJQ0OXytLqcgAsS/LTXzUQbAl/vQnq
+ PgWsyulVt3XtFJYs1kBA6w2dQ6fibHuxGLsmkEBs2OSN9waonGpngkfjdl+W3v4sNdVlLF8W
+ IJHI0tA8SPWSUrpuD/PyjgvNQXgsJzmo93Sz4M/Vs73OpxcqpFMG8WiWd34TYdMaD4phkU4Z
+ ZEYMDh6NUTXNwYpFLipKbVRVOshKN6u+Oh3TlPxsVyMNwRA1T5bhn+Ck45N4iexLBUPQBqAB
+ ZGFjoUPzLJupMPiJjlDgj006Cx+xkerLMCJACOgImYQHs6z4rJ1wt45QBNe7HSxfOw2Affuv
+ 8Y0NGn6/jyPHuln7tQrWrA5wuXHwVeCj+0Bg02xPHof/GiOckSQNiGUkPb2Ci606Tk3gcQja
+ Iya10+z0XdNRhECKPMqeKiXfpfHxidt4vElWLYphCgfbXxuidnk5s2Z4CUwtmG91J+a0QFCt
+ gmqHovygRDfJT1lMzUAoK5mHoCIDJRko0CVtCQu3KegeMLh0x6DxTpZsgZvVayrouZPk98fa
+ eXNHFgUj97j9NDalmT3TSzJl0Hw1PNIPf1IUqHmsoICAaVI8mq4OFI0KbBtdDWABsABBDYKV
+ Ph/rnp+BaUrefreFva87UaV+v+KfXZbl+KkepJQ8sagEAc/VgKZImFeuafcdO4GAGN8P2qVk
+ +gPvqCqkdJKLgx918PL38/Fo45tKoRahqsrOlaYhiifmMb2ysCQM1RpgNo6M4Ha7MaUkbhio
+ isKglChAkc2GzGYpcblQAJtpYikKj68u42pbBKnGWDIrAVIZe74B2PxCHj/f1cP8z/t54vFJ
+ 3LgV/4IGtN1KpQCsr6z0KN/eYCORFETjkqGIJBw2CfVDb1+c/v4skTgMDMHJX1xm7fpStr8U
+ wNIMkDIHlBKkBVhUuuB2bxcDgzqLFxSz/4P2uVoQfjwX9piwJTZs+1Hl1DzeOqxyN1lBYkTg
+ LbCjlEb4yYZLFHtACoW21JcomejA49FGO7iVO9djoAKJlBJXfojjp++wYK4fwKMBsgHuzoHg
+ pfowZv5iooZk5xtH2L17N1u3buXMycO092xj4mQN3bTjLyqnwOtAz5gMDSSJRXTiMZ1kIs3T
+ KwI5NpKbHRE6b8Wt7s6E+N0fOoWAa/erRcLVTMYikvHj8Wbp7OzE7XYzPDyMp2gKkU4/Vl4h
+ g4MW3jI/ll1l/6/PEn2/lYk2Gy5F4brdpOaZeaOZwocH6gHOmJbcISAwE+q0MRr3AAxE7eQX
+ ONm7dy/19fWcOHGCQCDAwkcmIp1e+iIxJuS5kEB7U4gVbvf9hlwwJR9LywMpicdSHKprBjjU
+ nJtA54OAco/WDBEgFY5DKiPYuXMnGzduZM+ePdTW1pKhEMtRRCgskIqJJSzirf3jxo3vM34s
+ AZYqOHm0DcuUSDg0tnIVxtudgcEMSd3A7XYTiUTwer34fD7chU6krZBY1MCyUoR6QxSmxh+D
+ yXP9WIxgSZ0Lp9sBWprh1lgfjfHW09sTnTF/wSy2b/smsWGNSCRCNBolv8COpTmxFJBSp725
+ h8n23DBuTSfxqTbmzc5HWkmkhCvnugAOPxB/PFBA/bu7/rJ0/YspXnlpKUPRDPvf+R4XG4d4
+ ZeujSEW9P0H7e4fxjHaoItVGVtGYNKUAgM4bYRKxNAKO/0tgE2yfY8qLH+67+NbRuubJ3321
+ hs3fmoeiqCAEEhM5WoFDoSTFqgrAJM1OS2YElzuXcbD+LsBIEv72IPBBDQnCb9MwKxbVd//y
+ hx9bzy/fx+Vz15FSx5JphMjpNtifxD0KBEjnq9xsHeTIwVYOf9AKcO4mpB+M/9BrIkAVzBfw
+ BvBk9cpKtrz2RS6d7WHV+tns3HyM8ps6Ybuka0Tnek+UTNq892lMwJYmOPBfAceAnxXwus2u
+ zvT584iFddK6MdalH7gC/B24kA9nzsPIP4v1HwEBakALw3ck1AroA1qAZqA5mAP+f9o/ACsL
+ HrLG8KKGAAAAAElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>iconForMenuItem: (in category 'menu decoration') -----
+ iconForMenuItem: anItem
+ "Answer the icon (or nil) corresponding to the (translated) string."
+
+ ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]!
Item was added:
+ ----- Method: MenuIcons class>>importAllIcons (in category 'import/export') -----
+ importAllIcons
+ "self importAllIcons; initialize"
+
+ | icons |
+ icons := FileDirectory default fileNames select: [:each | '*Icon.gif' match: each ].
+ icons do: [:icon | self importIconNamed: (icon upTo: $.)] !
Item was added:
+ ----- Method: MenuIcons class>>importIconNamed: (in category 'import/export') -----
+ importIconNamed: aString
+ "self importIconNamed: 'appearanceIcon'"
+ "will create a method appearanceIconContents holding the string representation of the
+ icon, and a method appearanceIcon to access a form built using that string"
+
+ | writer image stream |
+ writer := GIFReadWriter on: (FileStream fileNamed: './icons/', aString, '.gif').
+ image := [ writer nextImage]
+ ensure: [writer close].
+ "store string representation"
+ stream := String new writeStream.
+ stream nextPutAll: aString, 'Contents' ; cr.
+ stream nextPutAll: (self methodStart: aString).
+ image storeOn: stream.
+ stream nextPutAll: self methodEnd.
+ MenuIcons class compile: stream contents classified: 'private - icons' notifying: nil.
+ "create accessor method"
+ stream := String new writeStream.
+ stream nextPutAll: aString ; cr.
+ stream nextPutAll: (self methodAccessorFor: aString).
+ MenuIcons class compile: stream contents classified: 'accessing - icons' notifying: nil.
+ ^ stream contents!
Item was added:
+ ----- Method: MenuIcons class>>importPngIconNamed: (in category 'import/export') -----
+ importPngIconNamed: aString
+ "self importIconNamed: 'appearanceIcon'"
+ "will create a method appearanceIconContents holding the string representation of the
+ icon, and a method appearanceIcon to access a form built using that string"
+
+ | writer image stream |
+ writer := PNGReadWriter on: (FileStream fileNamed: './icons/', aString, '.png').
+ image := [ writer nextImage]
+ ensure: [writer close].
+ "store string representation"
+ stream := String new writeStream.
+ stream nextPutAll: aString, 'Contents' ; cr.
+ stream nextPutAll: (self methodStart: aString).
+ image storeOn: stream.
+ stream nextPutAll: self methodEnd.
+ MenuIcons class compile: stream contents classified: 'private - icons' notifying: nil.
+ "create accessor method"
+ stream := String new writeStream.
+ stream nextPutAll: aString ; cr.
+ stream nextPutAll: (self methodAccessorFor: aString).
+ MenuIcons class compile: stream contents classified: 'accessing - icons' notifying: nil.
+ ^ stream contents!
Item was added:
+ ----- Method: MenuIcons class>>initialize (in category 'class initialization') -----
+ initialize
+ "self initialize"
+ self initializeIcons.
+ Smalltalk addToStartUpList: self!
Item was added:
+ ----- Method: MenuIcons class>>initializeIcons (in category 'class initialization') -----
+ initializeIcons
+ "self initialize"
+ | methods |
+ Icons := IdentityDictionary new.
+ methods := self class selectors
+ select: [:each | '*Icon' match: each asString].
+ methods
+ do: [:each | Icons
+ at: each
+ put: (MenuIcons perform: each)].
+ self initializeTranslations.
+ !
Item was added:
+ ----- Method: MenuIcons class>>initializeTranslations (in category 'class initialization') -----
+ initializeTranslations
+ "Initialize the dictionary of <translated menu string>-><icon>"
+
+ TranslatedIcons := Dictionary new.
+ self itemsIcons do: [ :assoc |
+ assoc key do: [ :str | TranslatedIcons at: str translated asLowercase put: assoc value ]
+ ]!
Item was added:
+ ----- Method: MenuIcons class>>itemsIcons (in category 'menu decoration') -----
+ itemsIcons
+ "answer a collection of associations wordings -> icon to
+ decorate
+ the menus all over the image"
+ | icons |
+ icons := OrderedCollection new.
+
+ "icons add: #('Test Runner' ) -> self smallTrafficIcon."
+
+ "
+ world menu"
+ icons add: #('previous project' 'go to previous project') -> self smallProjectBackIcon.
+ icons add: #('go to next project') -> self smallProjectNextIcon.
+ icons add: #('select' ) -> self smallSelectIcon.
+ icons add: #('jump to project...' ) -> self smallProjectJumpIcon.
+ icons add: #('open...' ) -> self smallOpenIcon.
+ icons add: #('appearance...' ) -> self smallConfigurationIcon.
+ icons add: #('help...' ) -> self smallHelpIcon.
+ icons add: #('windows...' ) -> self smallWindowIcon.
+ icons add: #('changes...' ) -> self smallChangesIcon.
+ icons add: #('print PS to file...' ) -> self smallPrintIcon.
+ icons add: #('debug...' ) -> self smallDebugIcon.
+ icons add: #('export...' ) -> self smallExportIcon.
+ icons add: #('save' ) -> self smallSaveIcon.
+ icons add: #('save project on file...' ) -> self smallProjectSaveIcon.
+ icons add: #('save as...') -> self smallSaveAsIcon.
+ icons add: #('save as new version') -> self smallSaveNewIcon.
+ icons add: #('save and quit' ) -> self smallQuitIcon.
+ icons add: #('quit') -> self smallQuitNoSaveIcon.
+ icons add: #('load project from file...' ) -> self smallProjectLoadIcon.
+ ""
+ icons add: #('do it (d)' ) -> self smallDoItIcon.
+ icons add: #('inspect it (i)' 'explore it (I)' 'inspect world' 'explore world' 'inspect model' 'inspect morph' 'explore morph' 'inspect owner chain' 'explore' 'inspect' 'explore (I)' 'inspect (i)' 'basic inspect' ) -> self smallInspectItIcon.
+ icons add: #('print it (p)' ) -> self smallPrintIcon.
+ icons add: #('debug it' ) -> self smallDebugIcon.
+ icons add: #('tally it' ) -> self smallTimerIcon.
+ ""
+ icons add: #('copy (c)' 'copy to paste buffer' 'copy text' ) -> self smallCopyIcon.
+ icons add: #('paste (v)' 'paste...' ) -> self smallPasteIcon.
+ icons add: #('cut (x)' ) -> self smallCutIcon.
+ ""
+ icons add: #('accept (s)' 'yes' 'Yes' ) -> self smallOkIcon.
+ icons add: #('cancel (l)' 'no' 'No' ) -> self smallCancelIcon.
+ ""
+ icons add: #('do again (j)' ) -> self smallRedoIcon.
+ icons add: #('undo (z)' ) -> self smallUndoIcon.
+ ""
+ icons add: #( 'find class... (f)' 'find method...' ) -> self smallSearchIcon.
+ icons add: #('find...(f)' 'find again (g)') -> self smallFindIcon.
+ ""
+ icons add: #('remove' 'remove class (x)' 'delete method from changeset (d)' 'remove method from system (x)' 'delete class from change set (d)' 'remove class from system (x)' 'destroy change set (X)' ) -> self smallDeleteIcon.
+ icons add: #('add item...' 'new category...' 'new change set... (n)' ) -> self smallNewIcon.
+ ""
+ icons add: #('new morph...' 'objects (o)' ) -> self smallObjectCatalogIcon.
+ icons add: #('authoring tools...') -> self smallAuthoringToolsIcon.
+ icons add: #('projects...') -> self smallProjectIcon.
+ ""
+ icons add: #('make screenshot') -> self smallScreenshotIcon.
+
+ ""
+ icons add: #('leftFlush' ) -> self smallLeftFlushIcon.
+ icons add: #('rightFlush' ) -> self smallRightFlushIcon.
+ icons add: #('centered' 'set alignment... (u)' ) -> self smallCenteredIcon.
+ icons add: #('justified' ) -> self smallJustifiedIcon.
+ ""
+ icons add: #('set font... (k)' 'list font...' 'set subtitles font' 'change font' 'system fonts...' 'change font...' ) -> self smallFontsIcon.
+ icons add: #('full screen on') -> self smallFullscreenOnIcon.
+ icons add: #('full screen off' ) -> self smallFullscreenOffIcon.
+ ""
+ ^ icons!
Item was added:
+ ----- Method: MenuIcons class>>jumpIcon (in category 'private - icons') -----
+ jumpIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'jump'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self jumpIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>jumpIconContents (in category 'private - icons') -----
+ jumpIconContents
+ "Private - Method generated with the content of the file /home/dgd/jump.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACuElEQVRIie3WT2hcVRQG8N+dJtGkZiyiNpUs
+ 0gZRqWhM1GihxU1BMLhx0UVFKiJqXAhuxJV0UxHcFCvuSjbqzo0LqxUXXWgFE5GAUmtTzWia
+ ltraZuwkk8kcFxOT+Zc0JSIU+sHl8c495/u++9479z5u4HpHuqbsfvdhQNIFwjRGjfnpvxXs
+ tzcl+9G7QsapCG8Z8+H6BAf0Jj7A7jUZ42jwilGnrl3wIbtSxhG0g2wr2zdxd1Z0tUu5v/ll
+ hvELzJarKwtR9qTvHVujSQzKpgGn04BID4vMgZ54v/hpTMR0XIx8vBEjIYYqY2pnpBdFGqgZ
+ pw3KNqPONA2WHESPTIo4+Ki333zXcOuQrTabVwKbbKwkb7lVvLZRPFtD0bPI0YANDZFH7BDe
+ gxi+Nw0//ZIDngMTpj1lv098bdb8cs3Mn2zOS5cwuRTt0+2oKblVV5gp21Px2FHs2LfdO55f
+ mtumyyEvN9qOyjuMPehswrWaYITHwWN3tj2TdrjFzTXzg+7Rrq22qFioXFuxrQnXaoKSLRAP
+ 3GavJ0DO+aXpEV8qKC7nz12hkF8WqRL8l6saLQ2CS67Lsjqc8If7vWq3Pmf9Zay+xc5OIJbv
+ SysyriAYzki60/hFM0MFHzumZMFnRhur8xc4/1tNKE3UcdWh4ZGm5Btw/NzCifLvjjQTguIs
+ E6NE1equoEpwiasKDW0R3S6n8IKZUubHlpxCf6e8QuPKTh5nfq7W7GGqmyAyXq9vi8Y+nJLL
+ 3KUHfZdGJ81tvclC72KTl+Y58zOT4yxUvazAF6SvqsQZie8cqqdvvpcOyqaSH9ADdt4u9nUS
+ uVqhikHpI5ysif4aLR70rctrE6SyeW/wuVhsxAy6KhbiDtKUyq5yTs1H6iqb99WPpzaHFe1a
+ NW8Z6zieqvG/HcCNwuv+xbiB6x//APor/zPsp+AoAAAAAElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>loadProjectIcon (in category 'private - icons') -----
+ loadProjectIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'loadProject'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self loadProjectIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>loadProjectIconContents (in category 'private - icons') -----
+ loadProjectIconContents
+ "Private - Method generated with the content of the file /home/dgd/loadProject.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGz0lEQVRIia2Ue3CUVxXAf/d+376TzeZB3oGQ
+ BgykpOQhD4sUMFIeLTpFKoq0RVBwRKodp1ZnWizSoTgWiuO0yNCBFoulaYUyUqnOAGGYQcCk
+ JjSmPBMCm3eyyZJsdr/v2+/6RyAWdNqBembOnHvnnHN/c8899wj+D1Iyd7nPiEVLRFyVIu2Y
+ QNSKHtnQ0FBl3B4rPg9o/KxvpUnL2IZgKSBvc8dQbI3qic83H9sd/dzACTMf+aZS/E7XZGDa
+ A5P6Tqc8GJOji7KJW3G7+WzQqq8esJvOTgQuIOUTH1dXnbxr4PgZS2ZIYVcX53vFr1dmiYLC
+ dDb0LeZwWzZL3LXsGZoGQLzpbLv51iZTWYZfU7Kk4URVy+1l+EwpL3/YK4W9Kz3gZNdTeaIg
+ 0wmWSUWgCwmsGVVNgSsEgDZ2UqZrzctJCKHHhf06IO4YOOh1rAQKN383UyZ6JOgOzjgr+O35
+ Ig7lbMOjx3jA0zQSL5LT/XrlY63ArKIZix+6YyCI6VkpLntqcTJIjXPuEtY1zOJA9iskyTBY
+ Jve6O27JcExZMA6EgRDT7wJIeUmBRxyuy0VJBy1WGobSeOPifQSvZxAllZretFszpIbw+ltA
+ let3Acxwunyx37vnu+fZO/iqq4ajGWPY3jGP7SEgBLNHtbIl9Tij49dASIJmEs+keGVvpD/n
+ boB17zeYeYFZgbF2XKL1d7Mh+wOOdK3AsDVSnDF+M+bPiK5roBQABYBjsGcsij/ecUkVojbe
+ 350ZsTVev1SKcnrpNnwYtgZAyHBhDUZBSGzhASFp7dPpCBlCCHVGu1Ngen7REIpV6npvS83E
+ ZYELwUSuDPipt3NHYuYmXcYRM1jUtJrgNRfP7ay7agyEXZqm/eSOb9h4/E/HlVCvxuuO5dnn
+ TvUf9Uxmr/HFEX+SwyDbe51oXKPbEeDN2o7gQPu1PFBPNxyrunhXk6a8/GHvoNd5AijVxk+5
+ 6vj62jzh8jLKMcT+e3bijXQSDCkWbIkEjfaWHCGoajz+7qNwY7StLuMRJXkIRT4CTSiEAoFC
+ IhFCIWyQQiFu7hVohvBkhmVK+gVXuWX6MzsDuXn2NF9r9vmrA7KpIyKUsvuao9UfRu3eXmAd
+ NbSJNRWUuhMCtZXLniK/uJSEQACPz4fL40HTFJqEUF8XDoeL5OQAQmpIqWFEI7S3tPPm5p9x
+ 6nx39XlXRQwoBWIgakHVXIwe0q3lzmcRTtjdvZsaVuhxuLdoSiULV60DFQZl3aJxy+DIoR0k
+ 6W0kZkwmI3ccEybcg0tajCnwk146k3P/2ho5F79yBmhEUMM/2ANABW9xv4CCIjhtLqCmH10q
+ RhWUTAXV918wy4yx/pmneWLmRcblCqpO9lFSMQ2UweXWII9v2sqJ/kvwZGA+Y5iPLwZrh+rh
+ BhDSkDoE0iEvmA796Eqge7wJYJusf/UIORnpgAKlSPZFeGHzRvZsW8ulvhQamkJ8w+8G22TZ
+ Cy/x9+/0wugkSEwGXzJ0toBzyDPcWXhxi2JkHIHAHdUYAnTAoTkcoExyM9JYuqBypBvfeX8f
+ KJOyOd+jeGIBc5eYCIZvr1IdUDkVxCca/Uoz+EijnH1olPGD5Ezcktn2JI7V/y0GoKOQUgLK
+ INjZy4naj/5zgIqDMiiemA/KQAoLw4xSf6mJOTkFnLoUxl+YQZjIcLxHwcbEZAzrUZwm+DWS
+ s0pJOhXBDkWrbwKv9/d0gW3y/UX5GGYPqDidnT18eXYW2CYoi/BAmGX7ttHS2UdSkptUzYn3
+ tR4SNo1hEVP5A0ehcArETbBMnA4vX9EqmHglhS2/+CkotgNIBX2hjjZQFtlpLhyxMNXLn2dg
+ 8XreXfQcweYgKBO/10EkFmXD/QtZNrqMjyJBVicU0nq8ERubFVTCgavI/e1k/dPNjJNZnN74
+ Di8t+XFEDZg/opb9ALqUhMI97cMzQBkc2X6Axxs7h0v0cTd7X/uAb/9yMZve3s/5riAH62q4
+ 3N1Jjt/P175UzNuvvMfecYdx44AXz2LbalebXV/fJhHYNKKo4UO6br6STpxQf087oIFtMveH
+ C3jjbDP+5i7C+anMWz0bbJMnF85h/n1foDArhQS3Nvx19FR+Ps3NuqUvR6M+3Y2lDlLLyuE2
+ /9+ixwV9ofarKC0bYQ+RkZ3FYwd/xWAkhs/rBWWDiuH1DTF5XALYQ6BMEE7wTMLbe5QHB61n
+ /xKx6vBz9NNgAGLldFI0g/bRRWWOxJR0IuEQcctE0x1ITUfT9OG1/om1pg+rlJz5674hO24V
+ 7aih5dNAI0CAVWWUS0kF4FUKTQjkTYu6oQIbRfx2a+u8t/M0TZ/BGZF/A2P54ZZvw1VGAAAA
+ AElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>methodAccessorFor: (in category 'import/export') -----
+ methodAccessorFor: iconName
+ "Template method for an icon accessor method"
+
+ ^ '
+ ^ Icons
+ at: #{1}
+ ifAbsentPut: [ self {1}Contents ]' format: {iconName}!
Item was added:
+ ----- Method: MenuIcons class>>methodEnd (in category 'import/export') -----
+ methodEnd
+
+ ^ ''!
Item was added:
+ ----- Method: MenuIcons class>>methodStart: (in category 'import/export') -----
+ methodStart: aString
+
+ ^'^ '!
Item was added:
+ ----- Method: MenuIcons class>>objectCatalogIcon (in category 'private - icons') -----
+ objectCatalogIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'objectCatalog'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self objectCatalogIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>objectCatalogIconContents (in category 'private - icons') -----
+ objectCatalogIconContents
+ "Private - Method generated with the content of the file /home/dgd/objectCatalog.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAD5klEQVR4nN2VW2wUVRjH/+ecmdmd7c7e2qVb
+ uu1ulrZWoNUURYILSiKoBcRIN+gLUUKMifLiAzHEhHcVtInaxJQYY0g0Jo1CEBXaKBA3RhMp
+ 0Ai10NpUbO32uu3u7GXO8QF6o7NLL5FE/8nJZL75n+/3zZn5zgH+S6r0s+cAVN4z4NqQfLE6
+ KLcDkBY6hy6D56oOSIVHDjjvC/hYI4BCACW3rznFlgh7oNTL3n5jr7ZuZ1i1MEYq/F62v6pc
+ fnV4nNfHE6J5iXnnyVnooH++/oI22P5psRBR/5yxdb21D0BFvgSLXdIxVSGHO25k9LLiuYtz
+ /NtEouN6+n0AXfkSzHzsNRE75ExRTienWVxq6euLGc19MeP8roND35xr8ganHrsd1AKA363i
+ GSDVG2pDgffKfN6kmTF68aoxDPhv317jQowCwMnzyURPvyEatqgFTo3tuTnE37ob9JZqdr7Y
+ 9PkpMT4RNx2hp1/unm3fsFZpPxCxDwRLpEbNxp6tKpdaHQUkBsC6sDdcpG7GjJ4vziYP9Y8Y
+ pwAg3osvARAA4l8B9vYbu0zCeWHA8hp/SbrnwDlLeibanh4ajRtmxoSeUhaa1PMIHGlJeYJJ
+ dLshcHzinN42H8jR1tIa3dPSGjXPIpDIB7FvUlYTTupLKtyRVXUrHpKLJUrdDD80XrEDmAaS
+ hVadT1rYuu+x5+8/pvgtSExQ9FwbQurvNIrXSPijc0D/6/q4C6eRmvuGJrIBz/goi1AC5yBw
+ cswwPgaQvdPHCf/F7rEi2taD0Stjv/E0PyEovqMZ7ROtzuqfaNefiiP9VT6WJUDY94cs2shl
+ rVh0OXziQ9WdCFGpA8BKEz999HBVMniwUGhh676poD2svFnzUalw7bC1TMVMj6dyyj44qrq2
+ v2a121dQBg+heFhS5K2Sxfu1kdo4KvixO6aIuKJvKQ97QrFL8f50yDirlVqaJI1FhMxdkkZC
+ cZo6gj5kTdvCAbptt6LO26JWMxkPMjmAmT31ln+TpYnIvC4ukiAE6zVDXaf4pP361UzAVqtA
+ rVIsdkmpB8z7ULESknM/rCFygQRUT8M2WyrBySt6Z9YtNAHZy2pJlg/wDM+4nrRh4tcURs4k
+ khDEB5j/NOlRYeQ8Zi6LzGQW6Jyuzkj1Z51qrGhzQVHyRgaGLiih3GWM8HBiiG8EEQOqLX1i
+ +AImgRxtUUZZ87tW597dik2eHe/iWWybHPyp2zA2zI67HrcGeUbsAEU3Eakfxy5gJFfBuaSW
+ E/bzO6pzvNdRImLOleIzmye1irLfAQQXm2y28jU+8TD2khukQQDapOCnBzg/CkBfDvD/r38A
+ 0MR5I7Mls/AAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>objectsIcon (in category 'private - icons') -----
+ objectsIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'objects'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self objectsIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>objectsIconContents (in category 'private - icons') -----
+ objectsIconContents
+ "Private - Method generated with the content of the file /home/dgd/objects.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADhElEQVR4nMWWW0wcVRzGv3POXHZhZdldoAud
+ RkzRQFsaxBpTNcUtIMZaTdoQBa+tsYRYS2mjD/riiyY2pkL6JulTaUgkaayJ8aUoohgfWlOl
+ GiNqTY1chr1Bmc7uzuX40E4i7A7Nsqt+yTzM+X///++cyXeSAf5n1Ycp+2gDoVcrCVUVwr4s
+ BXvxXyEFKO0NE5o8UxK05/zVXPdv5JO+Kr5bkBcrCZkAIBUNJgHbFcKSCX8N5+VK1nNYLtVC
+ oIPFYBEAqCbsq6GSwMN7RE9Ok845apdmr6vc3gxgoRAgBYA0+NZ2UXY1eQlBq+CxBKC5EJgD
+ FEWASjcP66o6yrwcUIoBNGxAi3J7TePXVlqjwFQxgCAE50+klnQ30xXLwPec2xsU5bZAr4Su
+ ynJ62Zm9WgwANM4//9k2D4Qo8TUzaYXxJ8vAXi26aFZv6tnSsr/zrsad2tWpb/9yA4Yr2ECk
+ WW5Sk7ag6Xx8rc2Fqwgbq6dC8nXZd+N9r998XPDEA4SqAtDumNq6+59q7e5/s6OzP5jrALU1
+ bMacVPj2OnEBwJbVhqykSMBWC2iWgJABfGcCFwHc+Kdn76FDJfpyaQ/n9sLYyOBZAPxWaf/B
+ J0o/PP1WIPjLNRN7jkdVRolOCBBdtMr0NHl17WjeRq1PH7snOj99LDE9ETRSyzt3NEieD476
+ KzZvFFb4/pg18eAr6rXZmL2tICAAhMrZ5P310gMfnwgyWcweZ1rAfS/Nx3741egAcClnkvJR
+ LGlFLk+nhx49Ek2qieyrNXR+2fhz3joN4BLgEt08lZmL2b0/zvgOtPUltNXFhlpR9HrJJue9
+ GEB0dr4tNbU935hOm1Fn7crvBgyTY1eTDNjY7bAE1yl5KC4lj1siTlGCl1MZjoPvJBa/uJie
+ ppTXtNzrkcMV9I6ZqLULwHjBsNauvp727iN3A4BSxeYb7hRioTJ6+FaZAHiopoINl/uEiLOw
+ QuGWF0ZlWWxyA+ipzG/qxJnHACDyXN+TDGTpwvDAOABUBdk5NW69i5t3N6eyPiljdNvUuYE6
+ t4bGfUcBAO3P9O+wLbvswsjAJ05NjVv73PocrSs0jzz7msKJHRkbGRzOtzd/IAdlnPYGzJmT
+ efeuB0gAJhH7vdHRUes/AXIC47Ozp5bWA1sXsFBlpTRjWJmuN07OuTVoeqq4wIV4rOPTb67n
+ /l8EAN3OFAL8G3xJPtRdAsoRAAAAAElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>openIconContents (in category 'private - icons') -----
+ openIconContents
+ "Private - Method generated with the content of the file /home/dgd/open.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGO0lEQVRIieWWW0wc5xXHf9/MzuwNFnNbYLFJ
+ ggFjgs1l1yYhqTExdlKlbpVA7FiK08qt3SqqJSt5cCu/9MVSq0qtKiupZNLkIU2bKoG0TsCY
+ RtTGhYLDGjvBxlAcQ1i8G67mzt5m+jDLxU6jKm3y1CMdndGMvu93/uc78+nA/4UdzcEM8DOQ
+ Dm9j2xE3+YD4OljiSCmnEPwYWATmEtPSUmVZZmzk9hzwV0nibVWm4VQnM18FUHZncNSW4Mjd
+ 5PEo0xMTdmtcHAeOH2fnMzWqSVE2j/tGqhcXgy+6XTzkycD80AaGPxxh8b9WeNjNzwvKyo4f
+ e/lldF2nu6WF906fxpGcTM2xY7iys+lpb6ezsZGPWlsJh0IRBBfQqTNJvPvKhwS+lEKPC6ce
+ DVXv2rmAQCcjv4yKmn0oqsrvTpzA/0kfj3znacr37qVy/36cWVnS0vx89mQg8KSm6S+Wutjj
+ ySShOA1/d4Dp/6jwRx4KNZ2PT9W9gMooyDZIehxsm7h98ya/+uER8rcm84MTz4N1o+FCZWp0
+ lEtNTXQ2NjIyMGBsBl4N6pCpq71E/79V+K08JmdD/GTbrnLZ4ZAAHRb7IDxJfGYZkXCEno7L
+ PLbHCQt9MNMBwUGsFsgpLadi30FKKiux2O1M+P2u4Pz8LqFz1O3iGU8GE14/1+4Cnh9Ec7uo
+ ydq8OT0rOwEkFYQK0Rmw5ZGceT/v177Ojic9mG12EApE5iA4BDNdsHADR4JCwcM7qXruMLml
+ pUiyzJjP54yEwzUeF0VuF/VePxqADODOoNwSt66o9JEcAyYpxsamdVgTs7h64QIfdfyTnC3Z
+ 2BMcse8qyCpoYQjdhrkriIUeUtITKK56mh3VzzLc38+Yz7cZnSWvn4srwFIXGxdnF/ZU7Xvc
+ OIlloK6BZQMFZWXc7LnBO789Q2BkBmucg+SMVISkGhVZdqIQDMBcN6oSpuypF+g8e5aFmRmH
+ 10/tCnB7JmJxfv5Q1YFqFAUDJimgB0EyY0vMxLN7D+6qKob7B2n64wd8UN/JZ7dnQTaTlJaC
+ rFiMNZIaK/sdhKOUqdEx+q9cDXUHqAXChsIMAsBLuSVFijMzBSQTCJMRI1MQnQWixCWmsmXH
+ LnY/9zybPG6mJ6dpfa+Nd2qbCYUk8orzYqoVY73lPob7b9HTeSl4JWC+DNGADOD1o7ldVKhm
+ 68aiRz0g5FWokEEPQ2TaOKvwOESXSEhNJW9bBTtqnmXrNx7l3Jv1jPnv8OD2wliJFTC7+LR/
+ kI/b2pe6A+YGUGVpuV11ON/V8neiugUk66rLNpBsqxEgMgkLAzDbBUtDrM/bxLFXTtPd1sut
+ vnGQ40COB0BRVQSYjIWaZRWo87el+XkG+3wgWe52eTnem4jFgIfGiE9KYvfB79LacAkkO8h2
+ QKBYLAhh9AogrQBfvUwnMNjRdH71X5TMhosYUHxBApEp0DXK936bXu91giHJgCKhqCoIlBhG
+ WwEaVeW1tjPvc2d8brXVhXlN639BApLRlWarle1PfBPvhStGIkIgm0xIKyWVgmuBaCZej0Yi
+ wT/88jdomrz6e4hlxWsTMN+dgLYIukbl/v10NLUa71cqufwQDt0FfLUTn65z4Grrxeipl36K
+ b+BTAypMsbg2AeXzFdDmSXQ6cSSnMDoyDmJle6HKyCCCMvfYZT833C56x3y+na3179oHr90g
+ dcN9JKZnGLeQEIBkbLbsyLGog1BJTE+nz9tN9pYtBIaG6Wpu5vqYqT4UFUPSvUCA017eBnLR
+ +XVPe3vkF4e+z8mD36PhtTcY+cQXK+Ma5ctXoTCBHuKBwkJ0YonFzCJjAvnzCpfN6yfo9XOu
+ bD21IY1r45+N09/V5bxYV2f9R0Mj47cDKGYr65wZSLJpVTWAkNB1QVJ6OoHBIbqamxmYMP15
+ Lqz2funJrLqAMllIT5lNeqVF1otUs2p+oLCQnOJicktLyN66FYvNhhbVAGg7c4bfnzzJ2ZuW
+ Q8N3lv70P42CrnhSHkyRn7CpekWcqhdZFD1fkaX49Xl55JaUkJWfT8tbb3Hreu/Cm1etBxej
+ i3/5KmdPO5jTi9J0jzNOe3idJVpgNbEhojE1OCWfa/eZLsJSy9cy7AIy2FMAJ2gOkOZBvQVT
+ 0/8ClPo3sCGCJrEAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>paintIcon (in category 'private - icons') -----
+ paintIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'paint'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self paintIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>paintIconContents (in category 'private - icons') -----
+ paintIconContents
+ "Private - Method generated with the content of the file /home/dgd/paint.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAEK0lEQVR4nLXWW2xUdRoA8N85M53O2Av0Rgus
+ tJZCKASvUO+E3aBFN7IbWGNMdqMmPGlMdC/ZGB/U+GI0IfqiPigvGLImXtaYdReMAomu2TXB
+ FYGFRSUVSgstCKWdGTpzztmHKaQhiEaHLzk5+V++/M53/l9yTsqlibCHNS3kTjB8iYxKLKS1
+ my39c7JJX0Mm6eHFS+mF3ezYsLY7GXru2uTdh/qSK3PppJtl5zZUU5vPH3ovz65Yv34Nde2S
+ oMb1S2fBLVUHu+jC0w+t7aT9GtGZgiihrSUnYEnVwRRPLOnM1d7y81uJI6WxEyKhQqEMcVXB
+ Lhbhdw+u6WB2H2PfiGLKAvliCSarCqb4/fzZtambbr2e2kbGBsRxIBIaz5fgZNXAn5HDPf3L
+ ZjL3hsrkVIURJvJlAfurBmZYi8Zf9V9FXQeTp5k4WqkwCAwcGRezr2pgwAOLO3Nm9VxZmRjZ
+ DaKEdFA2li9FuWqB3czDL1Yvm0HTwilwVwWMA/l8Hv69h/GqgAH3Ibhz5aJKs0wMkx8Bcczg
+ 0VMCtk7P+amv9N7u2bVauhZXRsd2nVuIksCufcclvF8V8Ao60XtTbz2N84hKjHxxbr1Yju3+
+ 6tuxy/lXVcCQ1XDj4gZSGY7upFw4t35gaFyS2Lad8vS89I8FcUcQkCSJ/25/22XRqHmtKUFA
+ HLFt1yi8d4EH/dHRPP/qa3zWer+O324ycPUz/rS9x9YvSg6PTvpk38lCwuvnJ12wwn76WlmX
+ ITvI5q3nncNUDDe3t+vu7dXU3KwUxxb03ezz44u8smmjhDe/5tT3gneycCn/XEUqwB4eDvnN
+ P3jrvK3RgZ07fdLRJB1N+vqbQUE6LYoiA0fGinjhQsUEsJ7NXdz2Hx45zYcd/HUWc7NkM9Tt
+ 5tPXWXE2qYdHc3W1G5bd2CXbkBEFjAyfduxI4tihwxNxFN31FdsuBKYRNLJ0Di37WXiKkSFe
+ Ha6c7ztbGOrnqrMJK0kf4vFV110hW5NRnqQcJrJtDUYPHRZH0RvfhZ0Fkw0sXUl9LS+sYktW
+ 5QO2k+dv574t0w7/NEEYBE1zk6xykVKqApbDREdTncFD39Z9F8a0Lt3OeEDbBzz5N/5yBvdS
+ 28Lm1dwNS6g/yfI4STaOHJ/QnE9pyodmFkKNxVAuDqH4g8DbWTHCuq08FfPnUVyGXxPW8NrN
+ /LHIwTDwcYqP3th7YHjGRKgtn9IydR05Oibg04uB07s03cqX/eyYw7XLpyZbsIbMOzy7sr3b
+ L8MOj536/OVEkJ03lnGmJlFIx947M+TgyMn/Zdl4MTCYPuhndT0vddLVgAbUIYMU/p6qiR+Z
+ sTxcUMgp1sSOZUt2ZE54+8SAwfzEjjQP7OfgDwbhScKPmR/SENIQVe71CTPRdpzriql0thCV
+ UzgcVH7lN33J3otBZ+P/SNx4XWnWkNMAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>projectIcon (in category 'private - icons') -----
+ projectIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'project'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self projectIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>projectIconContents (in category 'private - icons') -----
+ projectIconContents
+ "Private - Method generated with the content of the file /home/dgd/project.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAF3ElEQVRIid2Va2xcRxXHfzN37j7sZBs77+A8
+ nIcTu25M4jYRKU0qqMqjIlLNoxQhERFUoKhfKJACElQBqRRqHq1SIqcQ2hKwKKkEaYhkpaZp
+ aFJqgwN2E9dJGtO4iet4d+3dtb2Pe+fw4a7Xtkz7BVVCHOlo5s49M/9z/uecGfh/FzX9455G
+ yrSiXixVaMIihEQIKQgpRVggJMW5Cv45QAEooPFK82kqUEDRe6CD04AogN2bWOloDgI7AP0u
+ BdcDbDUARnNYoDFSHmNtw828Z+0NlMUqKI9VUharoCxWQSRaRigaIRQO4YZdXNfgGE0oEkEp
+ hVgP6xew1kesw1hqjPjQEK91nKS99VHGUol64AYDKIEN6zZv56v729HagmRAJkCKLEkB8EH8
+ 4loOxHL3p79IU9NH+OQnPowSH40N7LQlfJ1PZcyyrn43S6prOfDNuxBNRN97E1VAeXX9VrTO
+ gVwBSYKMAxMg+QBEioBF4EQiwebqFO1HDzEwcHWaQ/5M20I/y1bXAaA9xOR9VmkFK2o3Mzh0
+ iWMv9YAIYAMtzufHIuzcvgYRj47OHlp+fpAH7hxj4TxNc/MDaMfl5N9Heeihr7OlsWYK0Eug
+ nQUA+AoxgAuwdNV6evsH6LmY5oNbG2Zl/BeHn+Oj25bTeFMT9zU5/PBzUBkzAOzdVaD3jSzj
+ 1LGlcV2RdltKgXYCO60Q42gcEQiFwyCWmhVLuWVz7SzA1j+1YRz43W8fofnhR9i4Zpgtsan/
+ P302yqP7vjKNTlsajUMJUGNxAIxrQOw7VLWA+KxfV8X+lmaeen4uACOZYE/j2hy9ff+akedJ
+ 1Y5Mo1SjETDGLQK+QxsWD9Mq8LrliKWjfxmxckV+7C0u/uYIG7//pSJQsWLF4mg7VTRYHBQ4
+ rhMYvB2gyAzPz/YXeP8HPsWBPTsAn1w2RyKZmk2p+EGrTUZoNUoJgGXenBBtp05zqqsroHCS
+ SmBORIrtERzU9tyPZ9AXDmmWLp5LNpflr+fO4xrYVrs6ACwmUSvEiCWjFIynR3hvzUIO/+CO
+ GQm3vsebb76F5xUo5HO4RpeoQnzyXp7O3vO82H2WVwsDxMMZoouiDHfGObHhfsDHcSJTgMAo
+ QGYkwcKFZTMO+/2vj3HoR63U5yyuQLcRtn9mB/ft+XgpR9892Mr5qkHGygyXX08ydnWCBRUT
+ pBel6ekfoH7lIpQbKVGqHUsKIJOMM/36On7sFF0PPs2zw5bvpeE7GXhmRGGe+DO/3HekdPvc
+ tqmOnO/RdaiHPbXbeOn+e9ld20jsuihPnjgNMi1CD9HKBhGmkvEZV9jTza08OKFnvl/Al/MO
+ xw+dKDl38/VriF9K48+3fOjGWlwHfN9n6G8p/ni1G98voJypCE22klQoDaPDw0F9TBZCtoA7
+ Cy4QnQ8c832PJ9teZPSNMaKrXF4+d4GW9r9w8pWLVN5Rhh8TjnedZ8etuVIO9a9eIAvk08lr
+ oCIlz2vet4EXlD8LrNd6VKxfAuLT2XeRr/3sGYYSKcIrDC+fe53qigoiqw1eyiL/EK6MeGQz
+ qdJ+UxxT6eS1BahIidJv7P0s97x6ie6zg9yZ04SV4nntcbh6Dk88tgvEp275YlZdX0ly/jjm
+ jEOoRvOTL+zk7tc2EjGahtWLccobuJpIzahSgNFM8toC9JxSr7kuHPzDt2k71sn+ox3kJnI0
+ 3lpH611bcTSAz9yoobv5W4xkMswrD5daaduGqqnWMksYvHQOACt4pQiHBi5QYDFuWMBPgR0H
+ fG7/2E5u39kEyp1SscE7abMgOeaFcyBZsLngsVYmsAsth2gD/zz5OEAuPEqfKV4mg/Er/Ty8
+ 6xZW1t2I7xVIxQfJjAyDUjjGxXFMMBoX/TbzSRttJtc68fKtnD76FAKdj10gFwAqWoDbLved
+ cS/3nfmPlflfyriCvQFUUT6/iWWOoU4Ly7A4aLS1aA0KhRZQCBpdHAUNuKKYfMRLqgQPRRJF
+ EiHhOrTve4X4uxHJ/578G1jL6Ak/aE7qAAAAAElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>publishIcon (in category 'private - icons') -----
+ publishIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'publish'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self publishIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>publishIconContents (in category 'private - icons') -----
+ publishIconContents
+ "Private - Method generated with the content of the file /home/dgd/publish.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAHJElEQVRIia2Ua2wU1xXHf/fOzK696/Uav7Fx
+ bIyhEIwDxgQETRojcEPd8gFCmwgRSKkKCh+oqFqllZJQWpK26iMvBAFUSkjSgEMaKESURsTm
+ EV7BaXEcnsbGxvb6xa5f693Zmbn9YENcR02x1CMd3TM6d+7/nv//3CP4P1hR2QqvGY0UCVvN
+ QDpRgagWXbK2trbCHLlX/M/TiimghyauEx2ZmvTIE6nSMl9G8DggR6SjKP4Y0X2/aKj8c+Te
+ AGeyG7/rSSwnTL/1G/LZTAU2wJSHl3xPKV7TNZk05xvTQueSvxmV903OwrZsp6Gm2bpY1efU
+ 19wPXEPKVZerKk5/NeBMSoFjbJ2DPj0Na8812HnlBJb67iT3sgIpnKqpeR7x29VjRX5BOptC
+ SznSmsWyuGr2DMwBwK6vCcTeeTGmLDNRU7Ko9mRF40gaYCYTKGYV8ApSkF04gaPGr5jy/VLY
+ Oe8hUuPOWqrnzfQkF7s25Ij8TBdYMUqSOpDA2rQq8t1BALTx0zLda1/yI4RuC2c3IL6osIR5
+ KJ6hJKU8ZUmhiGTrDOQYOIk68bgoYwa1NHK99Qba09UcWLqM8lnpoBuc98zl2cuz2Zu5Db9r
+ gFdvf5tdoeK7R8fO/O2a9Y/dE1Es1gAoZhVx2vsLdjz9tcmrS8Wt3D56PJ2o/gCYYSxPAldo
+ 5jZ94DNQhQnIQ/UsmX0/V+IfYM3nZRwZ9woJohcch7BI5mjfxLuAWlZBinViv4kQTToPkoLN
+ liUvrZfNhYqzgb3QchV64qHNDZMikJIz+KdtQVsdXO/mRvs4lDRotFIxlcYb1x+gPOM6KT6L
+ C7dT/1MmqSE8iY0q3D1Tx2KRGOf1+EpyOHt1MwRNeIEBWvr2oPqy+b23nEgvhNqg/SZ8Ek/S
+ Llt517wucD5gofsCH2Xksq3tUbYFgSCUprXwh5Tj3GffAiFpjvl5Jtkjb4e7s3VAL1o0j0+p
+ g3AIdhnQai/mEz6khMc4K8tJPAmtibDVUr52byAzrSwaTivMc+wjaN2dbMr6O8c6nsJ0NJJd
+ UX6XewjRcQuUAiAfMPq7xqP4i0RwMzjQTQ03wTsGdBsUPQAYHGZ/bwMbRTXPBX9ER+y+LPfs
+ vfT2ZIQdjd11M1AuD52mF9MZbIeg6cbqj4CQOCIehKQlpNMWNIUQ6rxOPscbq690Q5qfxDSY
+ Y8IZ8+vAOU4zAEwAy7krx8POX5US680Ptt98bfG63NqabLITvxhCCrhpppFhxlh6czXzw9Xs
+ 33ewCUiTmnZIUoHNpdBbfNwO0X7IVaCYO0xyZ1jMpePvHVdCbbX/VZnjXDnb/VH8dN42Z93N
+ +w2TLE8vEVuj00jireq25r7ArRxQP62trLg+yEMqpzkeWEG87qMyAs3Wblo49aWhMGR5qQWV
+ MUMrt2s/zlOBhiYxsdgvdIM0Y4CDE3bg6Wsl1BvmzS2HmmOfn8kWgorLJ977CQyNtjXFLOkQ
+ PHEJZvnAnAZt2iA/EokQCuGAFApx59tGavVGYWaLXpCupLTxJbcljctx5nhbsq429cn6trBA
+ iZCj+PGVk+/uunNZsbaEGXEJSdULlm8gb+p0EvyJxHu9uOPj0KRC0xyCwU4Ml8GYpCSElEip
+ YUYGCDR1smXz85xqklW3tbFRYAYQBVEN6oKmye21lRWB4ezoNhROfnAB5avXgQqCssCJgRp0
+ 24py7PB2/EYAX8Y0MrLzmTI5FzcxcvPG8MjCckJbnz224wKb/psEw01KRVp+0WxQoS+BWbEo
+ z/3s58wee4rvTL9BR/0pMjKSh/ZYEGvBcLmQIxrrq0xXAj3ekwDK4vmtlWRnpA89WMUYTy+b
+ f72RPS9voC6URG19iMf8cYNgQ5dyuXWUGgUgYGiGASrGuIw0Hv/WwrvJdw+/DU6M4vkrmTol
+ j7KlMQTWEOCgu9wSJVD3DqiQUgLKorm9i5PVnw1L26Aspk4ZDyqGFBZmLMLFugYy/PHkpCag
+ G8boKEXR293VAcrih4vHY8Y6QVm0t3fyUOnYu5X09PWyfN8WGtu78fvjyHS72Ld8BZruG1WF
+ UkEo2NYKyiYrNQ4j2kvVil/St3QT+xdvpLmhGZRFoscgHI2waW4Zy3Om8WlPM+3BIFL3jkpD
+ KSXBnq4AKAkqxrFtB1h5qZ35A4qVl7uo+tOHoGK8WPE+VztaOHjxn7xz/gLZjo+6QBemaY2S
+ Uptgd1cA0EBZlK0r543P6kms76AnL4VH15SCslhfXsqiokkUjE0iIU4b7FIthcrK0OiaxhaE
+ goEmlDYW4QyQkZXFkwc20x+O4PXEg3LAieDxeJk+MQGcAVAmCBd4iqmveRUBXfcMqNzc6myp
+ j73wVLnhS04n3BPEtmJouoHUdDRNH4z1YbGmD7o8z/mjeweUovJeAQXAD4qZKSUlgEcpNCGQ
+ d1bUkAscFPbI1dE5sPMc9fcK+G+8HDQjZjwS2gAAAABJRU5ErkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>smallAuthoringToolsIcon (in category 'accessing - icons') -----
+ smallAuthoringToolsIcon
+
+ ^ Icons
+ at: #smallAuthoringToolsIcon
+ ifAbsentPut: [ self smallAuthoringToolsIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallAuthoringToolsIconContents (in category 'private - icons') -----
+ smallAuthoringToolsIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 2808846277 4285241285 4285241285 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4104749094 16777215 16777215 16777215 4285241285 4288461528 3765147589 4285241285 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4156465773 4038761825 16777215 16777215 16777215 4285241285 4269385423 4287147474 4272275675 3898314177 16777215 16777215 16777215 16777215 797072384 4273576540 4294437589 4256074563 275795968 16777215 16777215 2892732357 4183986884 4286491090 4288461528 4255103704 3881930943 3064638120 3131747241 3920013734 4104492405 4293443700 4291597568 2693556224 16777215 16777215 16777215 2540345030 3580466371 4268792519 4286622160 4289118684 4270501585 4285635011 4294967295 4291342725 4292591497 4292980025 3953030672 4288257175 16777215 16777215 16777215 16777215 4083520451 3731461315 4285701320 4286227917 4289250269 4219249868 4286878622 4272851774 4292917094 4291794688 4124363449 4288257175 16777215 16777215 16777215 16777215 16777215 3951402422 4268004291 4286228432 4285636298 4272472796 4272064850 4291274851 4292526223 4071986259 4226279912 4288257175 16777215 16777215 16777215 16777215 16777215 4288257175 4259637483 4268725432 4286293452 4286030796 4273182039 4290882421 4289438090 4256807607 4260689397 4288257175 16777215 16777215 16777215 16777215 16777215 4288257175 4294901502 4259177190 4288849830 4289112743 4288981159 4288849829 4289375657 4275953373 4277795321 4288257175 16777215 16777215 16777215 16777215 16777215 4288257175 4294901502 4060020478 4294967295 4294967295 4294967295 4294967295 4294967295 3824020973 4277795321 4288257175 16777215 16777215 16777215 16777215 16777215 4288257175 4278124286 3003055870 3317805978 3874482915 4274568359 4291740331 4289906910 3102337511 3992582649 4288257175 16777215 16777215 16777215 16777215 16777215 4288257175 4278124286 3671774150 3233788567 4258252210 4292135090 4291940812 4290889933 3269254362 3791321850 4288257175 16777215 16777215 16777215 16777215 16777215 3868826775 4227726845 3923234754 2916008878 4241934256 4293847268 4290693332 4272668629 4190688481 3690790396 3868826775 16777215 16777215 16777215 16777215 16777215 3029965976 3471502058 4191934156 4192131794 4276808165 4294111470 4294177521 4292074211 4258191588 3506174971 3130694807 16777215 16777215 16777215 16777215 16777215 865835926 4070153367 3924421097 4244504061 4277926649 4294704122 4294506744 4294440951 3638484958 4019821720 1620219282 16777215 16777215 16777215 16777215 16777215 33554432 1553505174 3550059671 3952712855 4288257175 4288257175 4288257175 4288257175 3365510294 1653576333 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallBackIcon (in category 'private - icons') -----
+ smallBackIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallBack'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallBackIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallBackIconContents (in category 'private - icons') -----
+ smallBackIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallBack.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABqklEQVQ4jb3Sv0uUARgH8M9792bHmZRJJYIt
+ tghFeW8HJSGBhNDY0tAQKbRWUA1tTg5lf0AtTREaERWEEE1BDRZEtQSZS3CdyqXe+eP03rfh
+ BClJsKAvPNPzfL/Pry//iPQfM0edsk9GwdTWJPNa5TwUSUQqcg5sVh781rVf4pa2bLNLnQx9
+ 4Ef1O0YQowENEnMY885YXeCkUNkdiQvh2Q7DV4ZdC++p3n7PyCRhiu1pGkN2hNQSvsxXBfoC
+ kSweCYO+XYMn9PedN6HgsTcahLp1yunQKCMWKykbjV+Z6h1lfuV+IHITV904pPXMEQWlDXu2
+ aNJuD5hQMGeB0y8oLn0O0QYOZzeSi19ZmDWzWjWzuoKEVJp0yMIq1NLavMaAWiVjf4nG5npB
+ ucTEWxbnWK6wsrQWy1RSPFkk8bF+xC49Up673Jx1sMzOvVRK1DI8qFKMmY6ZrrIcr0+YuL7+
+ xi69Up4Z2J1xbJa4xngLd2cIDIp9E9iGUGJJYFKTl7/u3KVHpOhiNvG0KXE8SEQ+bWakjchr
+ Fxlfc2Is59zWBOoI5HXLy/8N+f/iJ/5OkGsa/+A/AAAAAElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>smallCancelIcon (in category 'accessing - icons') -----
+ smallCancelIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallCancel'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallCancelIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallCancelIconContents (in category 'private - icons') -----
+ smallCancelIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallCancel.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACC0lEQVR4nK2RX0hTYRjGf+d85882bWZMESIC
+ CSHOaYu6TIksRwRCXhgUOLqWsn9IlFAQ3YRSoFTQWEFGeFUXBd4FQVC3zrrJIOgiglzTOd12
+ tp23myY6XBfRe/XxPt/zvs/3++B/Vgx27oXdjfQ9EI5C+8aeXjs4kDhu8zVu8dmFvi2Gdx01
+ WThh892F85vELohctPHKvTFZfvVUxrYHSg4cqekuREe3mdnl6UnxBnrkWgDfgRiAAaCBlfOp
+ +Ok5U31ZYHTmiVUaTMzqK+W4D8X+sPnm6nSySfM89A/v+eWDArUpxT44fM6i6LUhK8k7svTy
+ sYwEVeFmi1VYev1McjMPpdyhZMTGdyBR82kbhzjQe8xmdqJFswr3pvA1DVpb0TMZAlcucDnr
+ +289hubhecOfcKHvko1X7VCSn7olq+PXpdSuy7BFxYVT9feN+oYG5i6FplerlMduoGmgTKhA
+ WYdvDTf/eUL//RAVaUN+NCPzBpJWSCaMFCLIWZN8FA40ij7wqIlqzZw2kCGDwoRNNa2QbBjJ
+ R5CEyVIU3PrNh1IbzPMGcsZgzYFuB05PBvDTClluQXIRZNBg8SCE1hlo0OoY6ItF+FmE21D4
+ WCH+Cd4BJIsErCAp8midYehU7JirEALW1lOcVKReNCODilUHurfgMzweQB4EkRjc3ZJDFHpc
+ iP4F8v6GEP+1fgOfrL0AYYB91QAAAABJRU5ErkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>smallCenteredIcon (in category 'accessing - icons') -----
+ smallCenteredIcon
+
+ ^ Icons
+ at: #smallCenteredIcon
+ ifAbsentPut: [ self smallCenteredIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallCenteredIconContents (in category 'private - icons') -----
+ smallCenteredIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 2862522779 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 2862522779 16777215 16777215 4288257175 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4289440683 4289440683 4289440683 4289440683 4289440683 4289440683 4289440683 4289440683 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294440950 4294440950 4294440950 4294440950 4294440950 4294440950 4294440950 4294440950 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4289309097 4289309097 4289309097 4289309097 4294572537 4294572536 4294506743 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572536 4294506743 4294440950 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572536 4294506743 4294440950 4294375157 4294309365 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4289440683 4289309097 4289309097 4289309097 4289309097 4289309097 4294309365 4294309364 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572536 4294375157 4294309365 4294309364 4294243571 4294177778 4294111985 4294243571 4294177779 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572536 4294506743 4294440950 4294375157 4294309365 4294309365 4294243572 4294177779 4294177778 4294111985 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294440950 4294375158 4294309365 4289309097 4289309097 4289309097 4289309097 4294111985 4294046193 4294046193 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294375157 4294309365 4294309364 4294046193 4294046193 4293980400 4293914607 4294046193 4293980400 4293980399 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294967295 4288454554 16777215 16777215 2862522779 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 2862522780 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallChangesIcon (in category 'accessing - icons') -----
+ smallChangesIcon
+
+ ^ Icons
+ at: #smallChangesIcon
+ ifAbsentPut: [ self smallChangesIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallChangesIconContents (in category 'private - icons') -----
+ smallChangesIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 490044345 2671475640 3728440505 4130765241 3845814969 3157949368 1395947704 87254732 16777215 16777215 16777215 2033415863 271610031 16777215 16777215 1345746614 4130962105 4201816526 4288331486 4289908199 4289907942 4288593630 4100561352 4030167480 1479833527 16777215 1714780343 4281563063 255031227 16777215 691173044 4114250680 4288134110 4289186277 4289448678 4290631148 4291288047 4292076787 4292602100 4291288045 4115827136 3224795577 4148724669 4231297207 238518454 16777215 2604301240 4252279246 4286425299 4282351034 4281628855 4231756985 4083652551 4272736226 4292798965 4292930549 4293062134 4254381786 4291879151 4181425337 222000817 16777215 4080630456 4282745533 4265508539 4114316473 1966241975 422804152 1161066169 3443096760 4117469896 4292141808 4293324792 4293587448 4293587448 4198202553 187593913 16777215 4264916919 4214979769 2641535701 3862395320 590575030 16777215 16777215 16777215 1613920439 4281628855 4291813359 4291682544 4293390584 4198202808 171147443 16777215 4231231415 2119404740 729984219 324965577 33587328 16777215 16777215 71336127 3292101303 4204509915 4293652984 4292930549 4293587448 4214980024 154759594 16777215 222000817 16777215 16777215 16777215 16777215 16777215 16777215 2687727799 4281563063 4165830334 4149447104 4149447104 4149447360 4281563063 138444991 16777215 4180899767 4264785847 4264785847 4248008631 4231231415 4214454199 3107157943 490044345 406156725 406156725 406156725 406156725 406156725 473396918 16777215 16777215 4231231415 4293521912 4293521912 4293456120 4255630561 3761732280 271610031 16777215 16777215 16777215 16777215 445231586 964537051 4231231415 204177599 16777215 4231297207 4293587448 4291616752 4291879151 4264785847 1781757623 16777215 16777215 16777215 187593913 3912595640 2373363157 3260780998 4281563063 87254732 16777215 4248271288 4293587448 4293390584 4293456376 4291419116 4115958721 3392765112 909407928 16777215 1781757623 3980361147 4283862726 4265311417 4197940152 16777215 16777215 4248402616 4292798965 4271947742 4293258743 4293062134 4292076530 4271619037 4115892929 4214519992 4282022840 4265245624 4282417339 4283665089 2822470841 16777215 16777215 4265048504 4150630087 3560339896 4099247298 4290630890 4291879409 4291091181 4290368490 4289383143 4287871453 4287476954 4288265438 4114184888 707885494 16777215 16777215 4281563063 2469820856 16777215 1412724406 3996678584 4082995909 4287608282 4288857058 4288923108 4288002782 4235765200 4130962105 1530230966 16777215 16777215 16777215 2721216695 16777471 16777215 16777215 87254732 1395947704 3191569337 3912858808 4197742775 3829103801 2856222137 607287480 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallConfigurationIcon (in category 'accessing - icons') -----
+ smallConfigurationIcon
+
+ ^ Icons
+ at: #smallConfigurationIcon
+ ifAbsentPut: [ self smallConfigurationIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallConfigurationIconContents (in category 'private - icons') -----
+ smallConfigurationIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4282944717 4282944717 4282944717 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1480812686 4282944717 4282944717 1480812686 4282944717 4291155690 4282944717 1480812686 4282944717 4282944717 16777215 16777215 16777215 16777215 16777215 16777215 4282944717 4291155690 4287805149 4282944717 4285374933 4289250531 4285374933 4282944717 4287805149 4291155690 4282944717 16777215 16777215 16777215 16777215 16777215 4282944717 4287805149 4289250531 4289250531 4289250531 4289250531 4289250531 4289250531 4289250531 4287805149 4282944717 16777215 16777215 16777215 16777215 16777215 1480812686 4282944717 4289250531 4287082715 4098460874 4284323793 4098460874 4287476956 4289250531 4282944717 1480812686 16777215 16777215 16777215 16777215 4282944717 4282944717 4285374933 4289250531 4098460874 2923986606 1497524108 2537911972 3998060491 4289250531 4285374933 4282944717 4282944717 16777215 16777215 16777215 4282944717 4291155690 4289250531 4289250531 4284323793 1497524108 16777215 1497524108 4284323793 4289250531 4289250531 4291155690 4282944717 16777215 16777215 16777215 4282944717 4282944717 4285374933 4289250531 4166095308 3445593287 1497524108 3225977527 4098460874 4289250531 4285374933 4282944717 4282944717 16777215 16777215 16777215 16777215 1480812686 4282944717 4291155690 4287082715 4166095308 4284323793 4098460874 4288330975 4289250531 4282944717 1480812686 16777215 16777215 16777215 16777215 16777215 4282944717 4287805149 4289250531 4289250531 4289250531 4289250531 4289250531 4289250531 4289250531 4287805149 4282944717 16777215 16777215 16777215 16777215 16777215 4282944717 4291155690 4287805149 4282944717 4285374933 4289250531 4285374933 4282944717 4287805149 4291155690 4282944717 16777215 16777215 16777215 16777215 16777215 16777215 4282944717 4282944717 1480812686 4282944717 4291155690 4282944717 1480812686 4282944717 4282944717 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4282944717 4282944717 4282944717 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallCopyIcon (in category 'accessing - icons') -----
+ smallCopyIcon
+
+ ^ Icons
+ at: #smallCopyIcon
+ ifAbsentPut: [ self smallCopyIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallCopyIconContents (in category 'private - icons') -----
+ smallCopyIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 1335796123 2140773783 2140773783 2140773783 2140773783 2140773783 2140773783 2140773783 2140773783 2140773783 2140773783 1403036570 16777215 16777215 16777215 16777215 2107219353 2147483647 2147483647 2147483647 2147483647 2147483647 2147483647 2147483647 2147483647 2147483647 2147483647 2140773783 16777215 16777215 16777215 16777215 2107219353 2147483647 2146694131 2146694129 2146694129 2146694129 2146694129 2146694129 2146694131 2146694131 2147483647 2140773783 16777215 16777215 16777215 16777215 2107219353 2147483647 2146694131 2144588753 3500845735 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 2879299995 2107219353 2147483647 2146694131 2146694131 4254834329 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288257175 2107219353 2147483647 2146694131 2144588753 4254768536 4294967295 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294967295 4288257175 2107219353 2147483647 2146694131 2146694129 4254834329 4294967295 4294177778 4291940816 4291940816 4291940816 4291940816 4291940816 4291940816 4294177778 4294967295 4288257175 2107219353 2147483647 2146694129 2144457169 4254768536 4294967295 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294967295 4288257175 2107219353 2147483647 2146562545 2146562545 4254834329 4294967295 4294177778 4291940816 4291940816 4291940816 4291940816 4291940816 4294177778 4294177778 4294967295 4288257175 2107219353 2147483647 2146562545 2144325583 4254768536 4294967295 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294704123 4294309365 4288257175 2107219353 2147220475 2146430959 2146430959 4254834329 4294967295 4294177778 4291940816 4291940816 4291940816 4291940816 4291940816 4294046193 4294572536 4291743694 4288257175 2107219353 2146825717 2146957301 2146825717 4254834329 4294967295 4294177778 4294177778 4294177778 4294177778 4294177778 4288520347 4288520347 4288520347 4288520347 4288257175 1352639388 2140904857 2140904857 2140904857 4254768536 4294901501 4294177778 4294177778 4294177778 4294177778 4294704123 4289243814 4294704123 4294572537 4293454312 4288257175 16777215 16777215 16777215 16777215 4221214104 4294704122 4294177778 4294177778 4294177778 4294704123 4294704123 4289243814 4294704123 4293519848 4288257175 3432619159 16777215 16777215 16777215 16777215 4221214104 4294375158 4294572536 4294506743 4294835708 4294769916 4292664540 4289243814 4293454312 4288257175 2140773783 16777215 16777215 16777215 16777215 16777215 2744950939 4288322968 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 3214580887 2140773783 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallCutIcon (in category 'accessing - icons') -----
+ smallCutIcon
+
+ ^ Icons
+ at: #smallCutIcon
+ ifAbsentPut: [ self smallCutIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallCutIconContents (in category 'private - icons') -----
+ smallCutIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 2086296920 4270888083 4169895821 16777215 16777215 16777215 16777215 3580785006 4271151255 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4288060314 4294440951 3950673018 3178000237 16777215 16777215 16777215 4254110610 4292401881 4018045312 16777215 16777215 16777215 16777215 16777215 16777215 4288257693 4292467931 4293980656 3833232506 16777215 16777215 1851284056 4290165433 4291744465 4288060571 16777215 16777215 16777215 16777215 16777215 16777215 4271217305 4290626241 4294441207 4186343815 3178000237 16777215 4288257693 4292073430 4290297019 4169435271 16777215 16777215 16777215 16777215 16777215 16777215 1700288598 4288323486 4292928482 4294046449 4001268610 3597693552 4290823620 4292204502 4288257693 3177671015 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4220227726 4290757570 4294572537 4271151254 4289441710 4290823106 4290823363 3900144248 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1549162838 4288257693 4293257190 4294309621 4289178795 4290033847 4287994521 1549162838 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3698554484 4290954692 4293651948 4290165433 4288389279 3580785006 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2539610207 4288060314 4291744208 4290625727 4283997890 1549162838 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2134145207 4266566084 4283212999 4287417300 4292537599 4292537599 4266631363 2134145207 16777215 16777215 16777215 16777215 16777215 16777215 2134145207 4288667371 4292537599 4292537599 4283213770 3744684890 4285454303 4292537599 4292537599 4292537599 4283212999 2134145207 16777215 16777215 16777215 2134145207 4288667371 4292537599 3945492591 4287941348 4279934652 16777215 458557696 4292537599 4283279307 4118390190 4292537599 4283212999 2134145207 16777215 16777215 4268539848 4292537599 3125100092 16777215 4287941605 4280000187 16777215 16777215 4283212743 4272087534 16777215 3057990715 4292537599 4281899979 16777215 16777215 4280130745 4288734706 16777215 3477099345 4292537599 4281899979 16777215 16777215 4281899979 4290041584 3544143702 16777215 4292537599 4281899979 16777215 16777215 4281899979 4292537599 4288734706 4292537599 4245856928 1549473302 16777215 16777215 1549473302 4269132498 4292537599 4292537599 4292537599 4245727654 16777215 16777215 16777215 4281899979 4280195254 4280130488 1549473302 16777215 16777215 16777215 16777215 2538548780 4281899979 4281899979 4281899979 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallDebugIcon (in category 'accessing - icons') -----
+ smallDebugIcon
+
+ ^ Icons
+ at: #smallDebugIcon
+ ifAbsentPut: [ self smallDebugIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallDebugIconContents (in category 'private - icons') -----
+ smallDebugIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2134145207 16777215 16777215 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2134145207 16777215 16777215 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2134145207 16777215 16777215 4231297207 4231297207 16777215 2134145207 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2134145207 4231297207 4290304767 4290304767 4231297207 4231297207 4231297207 16777215 4231297207 4231297207 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 4231297207 4290304767 4231297207 4290304767 4290304767 4290304767 4231297207 2134145207 16777215 16777215 16777215 16777215 16777215 4231297207 16777215 16777215 16777215 4231297207 4290304767 4290304767 4290304767 4290304767 4290304767 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 4231297207 2134145207 2134145207 4231297207 4290304767 4290304767 4281694904 4290304767 4290304767 4290304767 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 4231297207 4231297207 4231297207 4290304767 4290304767 4290304767 4281694904 4290304767 4290304767 4231297207 4231297207 4231297207 4281628855 16777215 16777215 16777215 16777215 16777215 16777215 4231297207 4290304767 4290304767 4290304767 4281694904 4290304767 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4231297207 2134145207 4231297207 4290304767 4290304767 4290304767 4285966811 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4231297207 16777215 16777215 4231297207 4231297207 4231297207 4231297207 2134145207 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4231297207 16777215 16777215 16777215 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4231297207 16777215 16777215 16777215 4231297207 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4231297207 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallDeleteIcon (in category 'accessing - icons') -----
+ smallDeleteIcon
+
+ ^ Icons
+ at: #smallDeleteIcon
+ ifAbsentPut: [ self smallDeleteIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallDeleteIconContents (in category 'private - icons') -----
+ smallDeleteIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1382511397 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 1986424869 16777215 1449488679 4287666543 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4288192890 1147498793 4284837928 4292994782 4287139466 4285493612 4285625199 4285822577 4285954164 4286151542 4286283129 4286480507 4286612094 4286809472 4286941059 4290691515 4292994782 4284837928 4284837928 4292994782 4284112991 4285888370 4286019958 4286283128 4286414715 4286612094 4286809473 4287006852 4287072902 4287270280 4287336074 4289243813 4292994782 4284837928 4284837928 4290955444 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4292994782 4290231460 4284837928 2590339368 4284837928 4288851047 4287338045 4287206716 4287075131 4286877754 4286614585 4286416951 4286022196 4285693233 4285495344 4285363760 4285035308 4284837928 2590207782 16777215 4284837928 4291812235 4290760282 4290760282 4290694233 4289904210 4289970017 4290232690 4289115217 4288325447 4287733059 4287272512 4288324968 4284837928 16777215 16777215 4284837928 4291812235 4290760282 4290760282 4290628441 4291022450 4292731857 4292731857 4292074155 4289575523 4288983124 4288391252 4288324716 4284837928 16777215 16777215 4284837928 4291943566 4290760282 4290760282 4292140202 4291088506 4290627953 4292139948 4292205742 4289509987 4289246047 4288917339 4289574266 4284837928 16777215 16777215 4284837928 4292009105 4290957409 4291220332 4292600262 4292731857 4290365032 4290101861 4290101613 4290956176 4289114972 4288719960 4289903745 4284837928 16777215 16777215 4284837928 4292337822 4291286129 4291286127 4292534726 4291285891 4290430569 4291942578 4290232689 4292468932 4288983643 4288390740 4290100612 4284837928 16777215 16777215 4284837928 4292403360 4291220334 4291154541 4291154294 4292205742 4291614119 4292600263 4292534470 4290035573 4288786006 4288259408 4289772418 4284837928 16777215 16777215 4284837928 4292206493 4291154538 4291022952 4290693989 4290365026 4290036063 4291679916 4289378136 4288983381 4288654161 4288127821 4289705854 4284837928 16777215 117440512 4284837928 4206542989 4292140187 4291943322 4291876761 4291614359 4291416725 4291284884 4291021715 4290890129 4290692752 4290363789 4204569458 4284837928 100663296 16777216 2103470115 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 4284837928 2120049952 33554432)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallDoItIcon (in category 'private - icons') -----
+ smallDoItIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallDoIt'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallDoItIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallDoItIconContents (in category 'private - icons') -----
+ smallDoItIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallDoIt.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0
+ RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAMRSURBVDiNfVNbaFRXFF3n3DNz
+ r3cm10nsaJxYMU5joon4QvGZYjUGtLZEBWkiRWwj+iEq4odIW6S0P/VXEIvFDzP4iB/6IRLR
+ ZDCjVpsJksekKsaQaXwlmceN9c6duWf7EQ0y2O6/zVqstdl7bUZE+L+qXzW3GEAFgM5QJJbK
+ x1m+wJ7ayl+IaCdj7HZ6TB4wvPyvJVWqO9qTyaRMuTYUif39IZ/nuW0JzhT7ThzzB5YtcG90
+ CYS/WqcXNW43iuo26MWJ11ZD/gQir896dEVyIdBQV6gvX2QHPyt1QzKG+AuZ0VVl457aygYC
+ Os0xWR+KxGzxznmmz+BnfAbH44GsJK5AuIHyOeP6BGDrJp82I+BetGKJh5+7nAy03jX3A/hN
+ AMBkQzn7XcMnqwt9ghV4OIgLXLgyaoXvmHYuR1hfbajbvixUv6hWOQAESzW15XZyHWPsuAAA
+ KVFaXu5h6jiOe1FTXmtLDjWFHx5kDP1ZZ86Piotvrts0RQ1HUnbTpZGRtq6hZgCCA4Ak+uHw
+ TwOJyL3XNnGBrphldT9NnJdE4Zwju3I2+/npgG0SF7BsBoDxpbOnDRNRlgPA7y09ZzIZ+qPj
+ wViGuILi6ZrqNyZNJ6IUAGgaX6npwkVcQU2N3/3rsbJpJVP104wxJgDg28/nba+c593d2Dir
+ gDjHmmq/cr8jvW13bVWh28Wl1yvW7tjx6WTiCgDAY3DQ+AXH1+w4pAZKJgmX5kIqnUVBgQtH
+ jlZ4e7rTX3s8AoESDZqm4OLFuNXaOpzjnLEnz9LNABwBAEQ4394+eijamSodTdjO0mVF7l3f
+ B/WqhVMmAkIA0mMSj4eSJyN9z05LIg7gCQeAUCSWMc3c4pY/48sfDiaPMs6zxBUMxi3s29vx
+ prk5niGuIFhmqH6fXuZI2UdEvUQkJ5IYisQcAL31q+Y6fb3pXGc0hZvX/3nT3T9yim5gQ9eD
+ ZMnwK8tq7xm6yhhTiMj56DO9S+ZCEnTk+ei/Zlv3YNM3KytuPXqemB/tf+mRRI+I6MV77kcF
+ JkDGBBHl/pMA4C2oHVtvUbiwmAAAAABJRU5ErkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>smallExpertIcon (in category 'private - icons') -----
+ smallExpertIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallExpert'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallExpertIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallExpertIconContents (in category 'private - icons') -----
+ smallExpertIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallExpert.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACS0lEQVR4nJWRu09TcRTHP+1tL33QVkjB0lqN
+ QABRiiE6SDCEElJcYWbV4GRSw9zBP8BFSRwk6mCiI4Mp0dCQaHwwgQllACqlPEIfVOhte3vb
+ n4M0ImICZzq/c36f73lJnMHehJDfRiiLGW44nGRGfMj6swjU1qObfoSHNWJ2lcZ7z1B0p4W/
+ PsEraTR61yg7BWHFwsRKM3On5X0+Jx/uXiM3NYRYGuPTx4c0AvyvAxm4CnQDWeAxsNpgZrLX
+ w/eZH9ieB1GlFRZOgseQSNY214pWf6twd7oFIID3wOXDP9dDIfQCdMc7eMo5xj13PPR099Du
+ biefyBOdjyLbZcIvw0qlXLkFfyobjsCjyIxzG1wXXTTVNdFyvoWOng7Mo2ZiuzEKhYJl9vXs
+ K+AmoAIcPeMEV8BoNVJjrMEsm7Fb7HjqPbS526iz1jEwMoCl3uIDAlWoKmAAfDRAqVyiWCqS
+ V/NklSzxVJxoIkrqIIWiKji8DoDe4yNYARPy70fyZ5LN9CY2k428mscoGUntp4in4miSBuA8
+ LpAFVsjQghXWU+uYZBOlcomtvS0kvcR+fp+N9AaZRAbg80lLnGaVB1wAIQTLm8vs5fZwWBzo
+ 9XqUosJ2bBttV8sB4Sp09IxmYJ4uOungXysAc0CW+8BkNSxVnVAopDcYDEs7iztdpa1SE4bD
+ 7AEQB90XnXrJeWkqGAy+6+/vVyORSO4vgUAgYHe5XA19fX0LxXRxmzjFynJFsiVtCa/R+214
+ aPjF4ODgohBC1jRN8fv96UgkIn4BMVjYCuwVUJAAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>smallExportIcon (in category 'private - icons') -----
+ smallExportIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallExport'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallExportIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallExportIconContents (in category 'private - icons') -----
+ smallExportIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallExport.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0
+ RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAJTSURBVDiNlZPNTxNhEMaf2d2y
+ 29IWW6rAoiEhVRP5sBIlcqgHL0YTrScvePDEyZuJqf+BB2/ExHjxwFUTKtFEkyZgoySgpGCU
+ AEK4uKLUVtvdbbfd3fEgEChN0Oc4mfc3z8w7Q8yMRgrGFRnATQA5ADPFTOVbozxqBAjGlSE1
+ 1vY0erpbbfepmExPlX4s564WM5WpAwGBC/K18EXfuO9UE9UKNkgU0NPVh6X0mvX17cYVAOsA
+ 1ouZigsAQj1RbpdGPapA5moVuefmRz1b0RcWs1DOsexpE9NSRFglkR9t5+8BpNRwgLVatjhj
+ FQsvy7d/vSj3G/O1QfNzzdF/m4je6kTizmUIihjYfiPtKc/87MlqcxevUSSh6bVgXPGKIZpQ
+ opLoaRGhiAp0S4djuF/2OUip4WGJecBnO4cB3N0KH1KOSRFRITCAUq2E7EIWANJ7hphSw61g
+ XurN637ZdeUPkaAJolhCy68E48rxJlWY9g/IrXKnB/lX5uzmmD5Y7+BByLKNUNWWfbaLTsMy
+ wPwYAIqZykpVc0/8nLBGN8asudJy/yjFks07DsY7QlEAK5LjFgTABkAAxKoohABcSmj513Tm
+ 3kMwj+yamUNE48x8Y7uFHgCeuh9lAIvXj4wMAZiMnT2P9o6jICLkNr9jdvoNAxiWACCh5T/V
+ 78OOYskQAHRHT0IU/xrwB4KYm3nnOI7dsm+R/lf/AnABwND1nUC5bMJ1HQGA2/CYdotiSZlI
+ eM/s9nq9PgtEKJtGExFpzNx3IGAL4gcQBzCw5XoeQIaz9wt/AFR4+5g8QPOiAAAAAElFTkSu
+ QmCC'!
Item was added:
+ ----- Method: MenuIcons class>>smallFindIcon (in category 'accessing - icons') -----
+ smallFindIcon
+
+ ^ Icons
+ at: #smallFindIcon
+ ifAbsentPut: [ self smallFindIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallFindIconContents (in category 'private - icons') -----
+ smallFindIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 3500845735 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 2879299995 16777215 16777215 16777215 16777215 4254834329 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288257175 16777215 16777215 16777215 16777215 4254768536 4294967295 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294177778 4294967295 4288257175 16777215 16777215 16777215 16777215 4254834329 4294967295 4294177778 4291940816 4291940816 4291940816 4291940816 4291940816 4291940816 4294177778 4294967295 4288257175 16777215 16777215 16777215 16777215 4254768536 4294967295 4294177778 4294177778 4294177778 4294177778 4292796125 4287862162 4287862162 4287862162 4287862162 4287927954 16777215 16777215 16777215 16777215 4254834329 4294967295 4294177778 4291940816 4291940816 4290164917 4287862162 4290430675 4289841372 4289578718 4290037208 4287862162 1552255106 16777215 16777215 16777215 4254768536 4294967295 4294177778 4294177778 4292796381 4287862162 4290036947 4288002781 4291288045 4291682288 4289119970 4288461783 4287862162 830636669 16777215 16777215 4254834329 4294967295 4294177778 4291940816 4287862162 4289772744 4287674587 4292996085 4293718521 4293456120 4291944945 4288200674 4255366615 4287862162 16777215 16777215 4254834329 4294967295 4294177778 4294177778 4287862162 4289578459 4289711079 4292864501 4293193462 4293061877 4291419375 4289383143 4270634460 4287862162 16777215 16777215 4254768536 4294901501 4294177778 4294177778 4287862162 4290038751 4289711336 4292338931 4292864758 4292142066 4291813617 4291156462 4253726428 4287862162 16777215 16777215 4221214104 4294704122 4294177778 4294177778 4287862162 4289970895 4287936987 4290565356 4291551216 4291419376 4292273395 4289645027 4221615577 4287862162 16777215 16777215 4221214104 4294967295 4294967295 4294967295 4292401366 4287862162 4289381852 4288463072 4290367719 4290499818 4289447648 4288856541 4287862162 3800664454 16777215 16777215 2744950939 4288322968 4288257175 4288257175 4288257175 4287665037 4287862162 4290630372 4288068314 4287281116 4289052891 4287862162 4289901490 4289901490 3632300413 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2306834557 4287862162 4287862162 4287862162 4287862162 4288585629 4291151300 4289901490 4289901490 4288059028 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4288585629 4291151300 4289901490 4288059028 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 33554432 4288585629 4288585629 4288059028)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallFontsIcon (in category 'accessing - icons') -----
+ smallFontsIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallFonts'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallFontsIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallFontsIconContents (in category 'private - icons') -----
+ smallFontsIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallFonts.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABw0lEQVR4nNWRP0xTURTGv3vP+8Pro9CqQ1Pw
+ 34tplIGYgIZASZogFWpinEy0mGCJiX+Cg4uM3R1MHNwMMwMrcRAGFhwaEjVRQTSS1DQMbaWN
+ 0tf77r0OakUWWDnJGb58J79zvhzg0BftFuPj03an5/XHI6erpdK6OAiA7xYVXZ8KtXW+Vu3W
+ 44Ne8B+AOM8BgON2TOz10ulbbipzP7YX0IqQzNxJCOEnORlHiYx4JBpb3Sp+WgOAgbHJR4Lo
+ 2U6j1nPy3MUnXV7vZScRn69sbMjWFqnFvWr52wspmrMA4IQjd/96vt94U1xfzRaW5nIqCOYs
+ 27kSqltT/yLk85wxlmqPHiuRZS0C0Kbjjnh9yRMAEA5HKt2J/pnBzO1lTubV33HJawGGCsUx
+ KcR3JnFzp1YdFU3/LQOzouHYNABIKWY58esfVhYegOnnAKC15gBgAIBSavLr58LDrS8f3wHA
+ hdHsiAn7le123AAwo5TcNsgwvd7hs8ToGgAwzttSqbxBA+mJrNbqkuse6S5tvl8AgONnzueC
+ ps8CIcqxUz3Jxo/6U61UFyPq+1krvwyk8Bnnoer22iYAMADmn97v5fY+M4exfgFP/5Zri/7V
+ SwAAAABJRU5ErkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>smallForwardIcon (in category 'private - icons') -----
+ smallForwardIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallForward'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallForwardIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallForwardIconContents (in category 'private - icons') -----
+ smallForwardIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallForward.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABr0lEQVQ4jb3ST0uUcRTF8c/jPDPqlKORiqSt
+ JqSNRfM0LlqElkRtItAIa9HWF9DKXkCbIAQhIohoURQFtQ2iYDYZkpAEUS1CamOBjppmOvNr
+ MZRUi/5And2F+z33cO/ln6tXt6KBv4N365SYkwgKbivq+LElAnv1YUjQLrIkWEAdBrVkthnt
+ YfwFMx/nRM6YdGXDomifxIrBzcFwLjiaDQ5mgr500J8OxvIhE46FsfV7IR7vDopRkLjsuFQt
+ QeKiVDTSUhpyMtOvS6u02IJlT7z0yLRVaw7YZacu1x/eND9aYq161ycnIokJjalepSPqpW3X
+ ql7arLL3yj+tpV2z2TvPODcN52ORipUKryasVta9DlWiOuI0cYaGJjry3wxmlcnHtSJoigVv
+ wbs1mpdRJVQIYWNsNkeujdVl3jzn0nzNK3Y2kjiNq9/lbEixNaYjxUgjqSWyLSx+oJTl2mJZ
+ 1YApk7UzJgqCHeo0qKqIfBZ0ilxwagv750ilub+JW/OLgkOeevzrR0pM6Y2CG7lguD5IzEgU
+ fg1+VcFhiRWJIPHAHm2/D2+kyEv0/Dn4v/QF8kyGaRoL4uEAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>smallFullScreenIcon (in category 'private - icons') -----
+ smallFullScreenIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallFullScreen'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallFullScreenIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallFullScreenIconContents (in category 'private - icons') -----
+ smallFullScreenIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallFullScreen.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADIklEQVR4nH2TTWhcVRzFz//e++7Me+1MxkxS
+ 0jR0nJZSbI0am07c2OomI7HrilB0GVy5kJDtZJNVEHQTcONKF2otlGmUEhoQSUtClTAWalJp
+ Pmtik/l47828efM+/m6yiFA8cDaHw1n84BAAMDNNTU2ZWutjWmsrCALDNE3HNM3q+Ph4gP8R
+ TU9P90oprwHIARBHHBJRi5nrQog9rfVap9N5OjEx0fzPwMzMTG6nuvVp+dmPH/fnTiad9ebO
+ Bxc++uVIJwbgMbMNYJ+INpj5t8nJyS0iYjk6OnpybXf12vbQ6mU+7xvVf+rd/UFuP22mIyIC
+ AAagiShFRD1E1EtEpxcXF7PFYrEq4ji2rIRFkR3B3nBx7t08/dS4ddULvB4AJwD0AegCoABI
+ Zu6N4/jNOI4vM/NZRURGvuesnX80uOqppvXEezLgd1hpqWMAICIJ4DgzHwNgA3CJKH2YaUVE
+ YcJIBO+9+v5TIQQeri+5sd9OLMz9MAgiYZkWeW2/menudc9deH03ne5yD9n4YRiGKgzDkIg6
+ RGQws3Xp5YKz8uDeqTvz91PKMAAAraaLysoy5m5/f/Hu7Tsbr7w2sjmQO+MqpTxFRB0hhB/H
+ sRRCSAAwrWRi6VkVXzeycCKB00kTQ6cK+OSzM+LDG5v57779Jr8wd9MYLFwtKwCNKIr2AdSZ
+ uYuIglS6S246LsJAISUktpvAhkO4K9O4nu7D8PAw7IbTr5RqKc/zqpZl7QA4OKSuojDg4ypE
+ MRWhS0vUgwjL+y10AFTaBoa0xt+7e3YGmQNRKpXazLzGzAfM/JiZ9xzb9nuojazyICMbL8kW
+ BlM+BgwbGdmElBLr61vPZ2dn6woAMpnMSq1WSwohiswc1WqNR1lCIYyqiEmCmZBLCJyQIZIc
+ od1qot5w/wDAEgDK5XI8Pz+/OTY29lgI4Wid6Cz9eq9QvPK2UtyAZBeafJjko08aqCwt88KD
+ Sqlet/+iFz2sVCqpPysPz9vV7a9G3iqMvDF8SXZnMxBSI/Da+PLzL36/+fP9dwDYLxw4qouA
+ drK4EofIsYBBgPLauHXgYQcA/gWOnHIlydMKjQAAAABJRU5ErkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>smallFullscreenOffIcon (in category 'accessing - icons') -----
+ smallFullscreenOffIcon
+
+ ^ Icons
+ at: #smallFullscreenOffIcon
+ ifAbsentPut: [ self smallFullscreenOffIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallFullscreenOffIconContents (in category 'private - icons') -----
+ smallFullscreenOffIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 3597627500 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 3597627500 4288322713 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4288322713 4288322713 4294966267 4290033079 4290033079 4290033079 4290033079 4294045933 4294045933 4294111726 4294111726 4290033079 4290033079 4290033079 4290033079 4294966267 4288322713 4288322713 4294966267 4290033079 4290033079 4290098872 4294045933 4294045933 4294111470 4294177519 4294177519 4294177519 4290098872 4290033079 4290033079 4294966267 4288322713 4288322713 4294966267 4290033079 4290098872 4290362044 4290822852 4294111726 4294111726 4294243312 4294243312 4290559423 4290296251 4290033079 4290033079 4294966267 4288322713 4288322713 4294966267 4290033079 4294111726 4290757059 4291612368 4292270298 4294177519 4294178289 4292072919 4291480782 4290691266 4294309105 4290098872 4294966267 4288322713 4288322713 4294966267 4294177519 4294177519 4294243312 4292270298 4292730849 4293125607 4293191400 4292928228 4292270298 4294374898 4294113010 4294374898 4294966267 4288322713 4288322713 4294966267 4294243312 4294243312 4294308849 4294178289 4293059814 4294309105 4294374130 4293191400 4294440435 4294440435 4294440691 4294178803 4294966267 4288322713 4288322713 4294966267 4294440691 4294440691 4294440691 4294506228 4293257193 4294505716 4294572277 4293651951 4294571509 4294376182 4294638070 4294637302 4294966267 4288322713 4288322713 4294966267 4294506484 4294506484 4294571509 4292007126 4292862435 4293454316 4293651951 4293322986 4292533470 4294638070 4294703863 4294637302 4294966267 4288322713 4288322713 4294966267 4290033079 4294572277 4290559423 4291086024 4291941333 4294571509 4294637302 4292401884 4291349196 4290559423 4294703863 4290033079 4294966267 4288322713 4288322713 4294966267 4290033079 4290033079 4290164665 4290427837 4294376182 4294638070 4294703095 4294768888 4290362044 4290098872 4290033079 4290033079 4294966267 4288322713 4288322713 4294966267 4290033079 4290033079 4290033079 4294703863 4294637302 4294441975 4294768888 4294834681 4294834681 4290033079 4290033079 4290033079 4294966267 4288322713 4288322713 4294966267 4290033079 4290033079 4290033079 4290033079 4294769656 4294769656 4294900474 4294834681 4290033079 4290033079 4290033079 4290033079 4294966267 4288322713 4288322713 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4294966267 4288322713 3647762028 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 4288322713 3698093161)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallFullscreenOnIcon (in category 'accessing - icons') -----
+ smallFullscreenOnIcon
+
+ ^ Icons
+ at: #smallFullscreenOnIcon
+ ifAbsentPut: [ self smallFullscreenOnIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallFullscreenOnIconContents (in category 'private - icons') -----
+ smallFullscreenOnIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 2576981400 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 2576981400 4288257175 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288257175 4288257175 4294967295 4281563063 4281563063 4281563063 4281563063 4294046192 4294046192 4294111985 4294111985 4281563063 4281563063 4281563063 4281563063 4294967295 4288257175 4288257175 4294967295 4281563063 4281563063 4281760184 4294046192 4294046192 4294111728 4294177777 4294177777 4294177777 4281760184 4281563063 4281563063 4294967295 4288257175 4288257175 4294967295 4281563063 4281760184 4282942140 4285175492 4294111985 4294111985 4294243571 4294243571 4283861695 4282679483 4281957047 4281563063 4294967295 4288257175 4288257175 4294967295 4281628855 4294111985 4284912835 4287672272 4289643482 4294177777 4294243827 4289052375 4287080654 4284584386 4294309364 4281825720 4294967295 4288257175 4288257175 4294967295 4294177778 4294177778 4294243570 4289511898 4291023329 4291943399 4292206568 4291286500 4289446362 4294375157 4294309621 4294375157 4294967295 4288257175 4288257175 4294967295 4294243570 4294243571 4294309107 4294243827 4291877862 4294309363 4294374901 4292272104 4294440693 4294440693 4294440949 4294375414 4294967295 4288257175 4288257175 4294967295 4294440949 4294440949 4294440950 4294506486 4292141033 4294506487 4294572536 4292863983 4294572537 4294572793 4294638329 4294638073 4294967295 4288257175 4288257175 4294967295 4294506743 4294506742 4294572280 4288461014 4290892259 4292535020 4292995311 4292009706 4289840862 4294638329 4294704122 4294638330 4294967295 4288257175 4288257175 4294967295 4281628855 4294572536 4283664831 4285701320 4288198101 4294572537 4294638330 4289381084 4286292684 4283599039 4294704122 4281563063 4294967295 4288257175 4288257175 4294967295 4281563063 4281759927 4282219705 4283204797 4294572793 4294638329 4294704123 4294769659 4282942140 4281825720 4281563063 4281563063 4294967295 4288257175 4288257175 4294967295 4281563063 4281563063 4281563063 4294704122 4294638330 4294638586 4294769916 4294835452 4294835452 4281563063 4281563063 4281563063 4294967295 4288257175 4288257175 4294967295 4281563063 4281563063 4281563063 4281563063 4294769915 4294769915 4294901245 4294835709 4281563063 4281563063 4281563063 4281563063 4294967295 4288257175 4288257175 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288257175 2643827092 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 2694091921)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallHelpIcon (in category 'accessing - icons') -----
+ smallHelpIcon
+
+ ^ Icons
+ at: #smallHelpIcon
+ ifAbsentPut: [ self smallHelpIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallHelpIconContents (in category 'private - icons') -----
+ smallHelpIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 672815513 2232900251 3306642333 4061617052 4061617052 3306642333 2232900251 672815513 16777215 16777215 16777215 16777215 16777215 16777215 33587328 2031573916 4113327778 4254773454 4291285987 4293849847 4293849847 4291285987 4254708174 4130104994 2014796699 33587328 16777215 16777215 16777215 33587328 3289865116 4133981369 4293455348 4290102746 4285699261 4282479274 4282479274 4285699261 4290168539 4293520883 4134047161 3289865116 33587328 16777215 16777215 2031573916 4134441147 4293652469 4284844728 4283530415 4291549157 4294178297 4293586676 4289971418 4283925171 4285633726 4293718518 4150890169 2031573916 16777215 672815513 4113459107 4293521140 4284779191 4279720860 4286159552 4294835710 4292732142 4294112760 4294967295 4291286244 4282151596 4286094019 4293586933 4130236322 672815513 2232900251 4271748304 4290102746 4279720860 4279720860 4283793842 4283925171 4281626024 4284845241 4294967295 4294770173 4283334836 4283071922 4290892002 4255234002 2232900251 3306642333 4291417573 4285699261 4279720860 4280574624 4281165988 4281822889 4282348973 4288065743 4294967295 4293718262 4283729335 4283860408 4287869136 4291812328 3307101598 4061617052 4293981175 4282085031 4280311967 4281165988 4281823145 4282414509 4286225605 4294638845 4294901502 4287606223 4284386493 4284518078 4286095046 4294112761 4061748381 4061617052 4293981175 4282216616 4280903075 4281757096 4282348973 4283006130 4293718518 4294967295 4289512155 4284846529 4285109698 4285241284 4286752203 4294178298 4061944989 3306642333 4291417573 4286027967 4281363109 4282151595 4282874544 4284188857 4291878122 4292009707 4285372612 4285438406 4285701320 4285898697 4289183708 4292141036 3307167391 2232900251 4254971088 4290365661 4281757352 4282480557 4283269044 4284254907 4288460756 4288723928 4285569735 4285964490 4286358733 4286555855 4291944429 4255957466 2233031837 672815513 4130236323 4293586933 4285962689 4282874544 4283597493 4285437634 4294967295 4294967295 4286292940 4286424783 4286884818 4289250528 4293981433 4130433443 672815513 16777215 2014796699 4134572988 4293784054 4286554310 4283794871 4285635011 4294967295 4294967295 4286621647 4286884818 4289447393 4294178811 4151876034 2015125149 16777215 16777215 33587328 3289865116 4151415997 4293784054 4291089381 4288197844 4286423754 4286949839 4289381599 4292141550 4294112762 4152270533 3290652832 33587328 16777215 16777215 16777215 33587328 2031573916 4130367396 4272471510 4292075243 4294178554 4294244347 4292403949 4256351709 4130630309 2015256221 33587328 16777215 16777215 16777215 16777215 16777215 16777215 672815513 2232900251 3306970782 4061879709 4061879709 3307233441 2233031837 672815513 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallHomeIcon (in category 'accessing - icons') -----
+ smallHomeIcon
+
+ ^ Icons
+ at: #smallHomeIcon
+ ifAbsentPut: [ self smallHomeIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallHomeIconContents (in category 'private - icons') -----
+ smallHomeIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 1291782669 4290904064 4290904064 2180975120 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1291782669 4290904064 4294904335 4294904335 4290904064 1291782669 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1291782669 4290904064 4294904335 4287978586 4288768873 4294904335 4290904064 1291782669 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1291782669 4290904064 4294904335 4289883499 4288059284 4289440682 4292057497 4294904335 4290904064 1291782669 16777215 16777215 16777215 16777215 16777215 1291782669 4290904064 4294904335 4289955460 4288717214 4291085765 4291677644 4291217093 4292128687 4294904335 4290904064 1291782669 16777215 16777215 16777215 1291782669 4290904064 4294904335 4290158236 4289704110 4291546058 4293190884 4293190884 4293190884 4292861919 4292264385 4294904335 4290904064 1291782669 16777215 1291782669 4290904064 4294904335 4290228141 4289901233 4292993505 4293848814 4293848814 4293848814 4293783021 4293783021 4293717228 4293253336 4294904335 4290904064 1291782669 4290904064 4294904335 4290822334 4289835696 4292927712 4293651435 4293717228 4293717228 4293717228 4293651435 4293519849 4293519849 4293519849 4293716457 4294904335 4290904064 1740701696 4294904335 4293388776 4284967526 4284967526 4284967526 4284967526 4293717228 4287269773 4287138960 4287137928 4287138960 4287138185 4294440951 4294904335 1455489024 16777215 4284967526 4294243572 4284967526 4287665037 4287730830 4287796367 4293717228 4287138959 4286949841 4287137928 4286818512 4287073167 4294375158 4284967526 16777215 16777215 4284967526 4294177779 4284967526 4288059539 4288059539 4288059539 4293717228 4287073166 4285110471 4287137928 4283533503 4286941325 4294309365 4284967526 16777215 16777215 4284967526 4294111986 4284967526 4288191125 4288191125 4288453494 4293717228 4286811028 4281563063 4287137928 4281563063 4286613908 4294309365 4284967526 16777215 16777215 4284967526 4294111986 4284967526 4288191382 4288191382 4288322448 4293717228 4290691267 4291086541 4291217352 4291152333 4289967027 4294309365 4284967526 16777215 16777215 4284967526 4294046193 4284967526 4288257175 4288257175 4288257175 4293717228 4289835441 4289901234 4289901234 4289901234 4289901234 4294309365 4284967526 16777215 16777215 4284967526 4294440951 4286085750 4289178277 4289243814 4289309350 4294309365 4294440951 4294440951 4294440951 4294440951 4294440951 4294769916 4284967526 16777215 16777215 2892392806 4284967526 4284967526 4284967526 4284967526 4284967526 4284967526 4284967526 4284967526 4284967526 4284967526 4284967526 4284967526 2540137061 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallInspectItIcon (in category 'private - icons') -----
+ smallInspectItIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallInspectIt'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallInspectItIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallInspectItIconContents (in category 'private - icons') -----
+ smallInspectItIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallInspectIt.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACX0lEQVR4nKWST08TURTFT2f6nyntlJbWAq2h
+ BYxUSAoblBg0rsTECiEkfgANSgyuXejaj2CMicaFhhhdINGYKAYQYjUYTG1EBIZph1JaSodO
+ W9uZqSvISAYT41299847v3fuzQP+szQHD3wNtf2+o9Yhu03frNUSBp6vrJZF6cnUNPtCDaBV
+ rG2dQef9sZFQX9/p5oLB6lmRqwa+xDMdk5OxS5IoR1bZ7eF4vJhQS0C1+unx188H+yr0ufdr
+ 5LBBeYkqzZXq+YehkbFX62+mmB4A4p5GAgBNG++8fBo+L3kGp1lywHww5qZA10wu6G03wnnv
+ x4VkY3JTmNjTCADobHd2N3rdCY64YFHrsyLJBJu1GCVrx/LxFnuvUiMAWNpa6LqCxsuqmQFA
+ KPzSAcDiRqPJ5TI7AeiUAKfnCAVJY5IOA2R3BCMAVGQ9HLRZC8CqBKzMRzi+prrmUDOn0rwp
+ 9oN1AUDAniww8VwKQPqPGURjmSW5lAlZq9Hd/b5FiYgtJ+xvZ7/6RVEm9ZDELvMXOs7ll5QP
+ kACQ48vR+chGz/WBYluy4E7PLPJNc5+WfCyXpiVJJkx6qXzv2ShVM/7ZzpxsIKKxbEQoivF9
+ AICdrUwpOheJnxnqSXV1eLitOqpYDjhyhXDw2+5F7yxtybnNuHqC6KV4K6MznF1niu+EUjl1
+ 8CvbAs22260BOuRxU26djtRv7xQTCS4fJQnNsYkHV05RmTRZZRYrg4/XuZ+s0H7Y4PfSEYq9
+ sdVPP/o+c3NXmr8s3r3VnQoG611/A6iW02kaDff7P/iaaq/9s1mtfgOeOPMUwSrvxgAAAABJ
+ RU5ErkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>smallJumpIcon (in category 'private - icons') -----
+ smallJumpIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallJump'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallJumpIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallJumpIconContents (in category 'private - icons') -----
+ smallJumpIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallJump.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABdklEQVQ4jcWSPUuCcRTFf/d51LSIgmfphSBo
+ iobCBx16oSUaApemgqCGQGhq6wNEn6ChrakIWlskiKgpqCdqqKkXSlJCibA3M/U2aFZaEDR4
+ xv8593DP/R+oNuRXxqYDxS6qHBzO/2Zg4xeXLJPV7jLlgSphHA6/Pptlw8MCO572RmtsYda0
+ Jnq49L8h6UclmmkVmKaFPeI/bRPEkiC3xlzT82p+W1/1TRd1Q306qjwNKEuo2KjYxAhifYwZ
+ JYMsIbxm3dT8nG9cBsmRZ41dXsiAYUIA6BWAZrKEKgwMIUBn/dOke4gkKby4aaC2QD4kAdBu
+ /dQW4fp+KDG8eOhiBh81XJMAVbiLFXitTF7aIK/sc5KqW8lskSBVHM7DxQE83hX8nS/ail9o
+ Iyo5wufRM/dzX6NJ+h6ujiGVKPC7IBEA4riY5YYXKO+BzbAIESwR7VdoAe5BjgROFSCnMILD
+ Zil1RSgbv9TLOg/a8f0+Pxfp31WuPt4BdGiFIfxoncEAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>smallJustifiedIcon (in category 'accessing - icons') -----
+ smallJustifiedIcon
+
+ ^ Icons
+ at: #smallJustifiedIcon
+ ifAbsentPut: [ self smallJustifiedIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallJustifiedIconContents (in category 'private - icons') -----
+ smallJustifiedIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 2862522779 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 2862522779 16777215 16777215 4288257175 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4289440683 4289440683 4289440683 4289440683 4289440683 4289440683 4289440683 4289440683 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294440950 4294440950 4294440950 4294440950 4294440950 4294440950 4294440950 4294440950 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4294506743 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572536 4294506743 4294440950 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572536 4294506743 4294440950 4294375157 4294309365 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4294309364 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294375157 4294375157 4294309365 4294309364 4294243571 4294177778 4294111985 4294046193 4294177779 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572536 4294506743 4294440950 4294375157 4294309365 4294309365 4294243572 4294177779 4294177778 4294111985 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294440950 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4294046193 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294375157 4294177778 4294111985 4294046193 4294046193 4293980400 4293914607 4293848814 4293783021 4293980399 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294967295 4288454554 16777215 16777215 2862522779 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 2862522780 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallLanguageIcon (in category 'private - icons') -----
+ smallLanguageIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallLanguage'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLanguageIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallLanguageIconContents (in category 'private - icons') -----
+ smallLanguageIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallLanguage.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABlElEQVR4nMWRv0sbARTHP+bulOCQwaQnauoF
+ rYGiDpa2Wtupg7q5Fsng/+CmODqUigouDuLg4L/goCBxiFkEtRXj0CVNuWhE6cn9MOZeB1NI
+ S07qlC+84T34fHnf96DRaqozawE+Aa8ikchLTdOaS6XSN+AY2ASsxwxTuq7/XFz8LPn8d/F9
+ V0Q8Mc28rK+vSSJh3AAzgXBvb49/eVkQEa9u2faNDA+/FWCu3tr24WE2EP5TppkXTdMEeA6g
+ Vg3eGUZ3uF9R+PVlCTXehZowqBQvENtG6ezAy2RRYlHaPrxndHSEvb30R2AjVDVwXNflLneO
+ 1vcCpV2n+c1rymc5lK5OvEwWymWaWlupFAo4jgvg1EZQAHN3Z1tEPPHvbh9Wrjh/974r52cn
+ EgqFHKDt3zsM6fqz61zua2D+YvGHJJN9LjAe9AkjHA5nVleXxbKuxPddsawrOTjYl/n52fto
+ NLoF9AfBAKiqmj09PZJ0elcGBwcqwA4wCUQeBauKT0yM+anUlAesAPH/gWo1DSwAsaeCjdNv
+ pz0BrfQjq7kAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>smallLeftFlushIcon (in category 'accessing - icons') -----
+ smallLeftFlushIcon
+
+ ^ Icons
+ at: #smallLeftFlushIcon
+ ifAbsentPut: [ self smallLeftFlushIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallLeftFlushIconContents (in category 'private - icons') -----
+ smallLeftFlushIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 2862522779 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 2862522779 16777215 16777215 4288257175 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4289309097 4289309097 4289309097 4289309097 4289309097 4294572537 4294572537 4294572536 4294506743 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572536 4294506743 4294440950 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294440950 4294440950 4294440950 4294440950 4294375157 4294309365 4294309364 4294375157 4294309365 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4289440683 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4294309365 4294309364 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572536 4294572536 4294506743 4294440950 4294375157 4294309365 4294309364 4294243571 4294177779 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572536 4294309365 4294309364 4294243571 4294177778 4294309365 4294243572 4294177779 4294177778 4294111985 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294440950 4289309097 4289309097 4289309097 4289309097 4294243571 4294177778 4294111985 4294046193 4294046193 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294375157 4294309365 4294309364 4294243571 4294177779 4294111986 4294046193 4294046193 4293980400 4293980399 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294967295 4288454554 16777215 16777215 2862522779 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 2862522780 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallLoadProjectIcon (in category 'private - icons') -----
+ smallLoadProjectIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallLoadProject'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLoadProjectIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallLoadProjectIconContents (in category 'private - icons') -----
+ smallLoadProjectIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallLoadProject.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADA0lEQVQ4jY2SW0zbZRjGf9+/358eKIUW6AE7
+ SlvcxiImc8PIlnmKkmAyt5ktWaYx8cAu1At3ockWZ2I27iDemHjjMTEsgnE6ncQsJrhMM2RM
+ kQnLQKRoS4GW0lJKD/T/eWe8EOJ7++b3vHne5xH8j2l56MjjhmF6QkBIYYwZQl2YunpxEsC0
+ JXnsmOke966+XU3Os/aO4w3r7SeahMvrZ+7O87X+7So5Nzm8pcBO1843nzpQ9/K7r3jNDTua
+ Xc/UjFf9WH/QW7r/iKN889vttf7wLW0LXjjsFafOnqgXCUuA8nKaVtsM+8wR0M0m/fgZuzC0
+ V+Wm1x8+HPDVWUV8zU2hsooLyd2YSgYRw0l7dYxFm9t7S4jWTQVM6InpeDH1UzbgOOoaw+w8
+ wBvZw/zQ8g5kkqTWFB0Wrbiphd+GBrLlYjFyfvKu+cvxe/l51c16WZIvCC7F7+N0v1peXS/1
+ b/UDBMaLhc96ymfGGmMFw0RX7QhmY5We79KR769P/1m2r3eLrr10un3B3lp/yOkNNEtzZaWm
+ 61JomgCBSC8l1ODlQUatj2Y8TmtFKbfmmM1MDUdDE/VMr+2XUuqd574cbREqDarAYux3ZkY+
+ wtCqaXvkKLl8lmvRiJqc/XRgWtpkydZxkj23r9IVaOXQRKes99/dmFqJk1gpgTKwCI1CbgV7
+ jRldK/LYh29x4+mUoDF4snRlKc9zA130VgU0iwsDhHR5/N50ZpmNsg9QFFWUBw+dQlAklVnC
+ 7HWit4cpsQHNixY+dxYIaTL8l5cpjT9kPpvJBX02ssk73P7gEpVtYYQnxLMfv41UGsFcgbkF
+ Mw2eMCPBLL7dbumPVDHR/fV17PwqkwuRGIZivG+QB3q+YnjvNrb1v8R8fIk2TxNWn5XZ3pny
+ L/tmTcb54aEo9EcVCzj4hiHyMp2Yj61mNmh74SA33DUE9+xAaE6uvNYNqgBaNXXj76Wvnbt4
+ GsEnjJL7d9RSCfpef3J/SJXLJqXUPwtNSqHrZk1WWEQuu/IFN3n/v7ryN/fUMc5/02mQAAAA
+ AElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>smallNewIcon (in category 'private - icons') -----
+ smallNewIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallNew'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallNewIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallNewIconContents (in category 'private - icons') -----
+ smallNewIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallNew.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACb0lEQVR4nI2RzWsUaRCHn3r7ne6e7p5MPjTu
+ mMRE8bIOe9iFsKwiePAgQcGFBW+aYy7e/APyXwQPe9uL5CJIbnszgrCw7IQISr7Nl05kY9Rm
+ ZpJ53/LQKIgfWJeqQz1Vv1+V8I24dH2y98iVhowJhsXrsBcdBjmuav569GDmMYAtGqfGvNM/
+ EH6Kk2j05OCxU0kS1yppEvdkKZVKRpYlVLKUl81X3Lv/98/ABQD57erUkBVduHljov/X8XHS
+ ai/tQ8g7nrztyDuOI6c4p3Q9XK5H/H7rTuvhL7WM6WlvrLizfb2V/omJK7hSD/u5J+84nPNY
+ K1TigJ5yQDW1VJOAUlSmr1opn/9v53RhQSQ7MTiAKqRxgPeKU3Be8b7IH+quV7pOGRup8Xox
+ rwMrRpUDAZLQUA4N5ciQhIY0MiRRkbM4II0NQ/0hWRwwOlJD8fVCgdVm3moTlQxOQb3iFbwW
+ W70qcWioJpbQCgBjIzWAc8WAQ7uX5y1KgRBZQVUKWAVrhCQy2EA+ee/o8A8AdQAzPzfz+s3b
+ vCOilKxQskJoTXG8JPgMBhg7VQP4kelpYwA96naf/79/gDWCDYQ4NJTs5+CHGOirkibl+NK/
+ zTMGQGF9e7dJYArZ5uvsJyqcuroBEJWN7Rd7iIB8BwwwUhsEtBighvXt3VffR1J85uBtjogJ
+ LYBR1nde7H2xud3usLKxw/LaJkurmyyvbbG6sU27c9gQCf60AD5w/yw+W+0uPl2x7/IWK+tb
+ LK1usby2ydZOs6WqT0AXvNAQrw31dmF+7u4+wEfHF69NTSJ6G9hFpCHogvHaOB7vL83Ozrqv
+ 2XkPgdkFGpcRD6AAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>smallObjectCatalogIcon (in category 'private - icons') -----
+ smallObjectCatalogIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallObjectCatalog'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallObjectCatalogIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallObjectCatalogIconContents (in category 'private - icons') -----
+ smallObjectCatalogIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallObjectCatalog.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB9UlEQVR4nGNgIAxYGBgYuIlQhx2YqrNFR7hx
+ bcAlz4xHL6OiDKuZkQZbUUMynyM/N6MTEyNj0IMXf1cQZbOICINkuAvXpR+HpP//Py7z/9Q8
+ sY9OJuye6OpYGBgYGMzDC90EBHidYIJ//zIw7Tl7unvlnu1mJhqs5xJ9uDXff/7HdPvx/8dY
+ DZCWFvVZ0JSbCxO8dOshw57YS8sYGBgu7D714+/eUz/KmJmZ5MSF/hs+fslwBcMAfGDXqZ82
+ DAwMH3HJMxEyAJ9muAvevvt0o3ry0o0wwU9ffrAzMP9F1RjKwMz7gtPCwFk2+8e/X/qnDz3Q
+ ZzjA8IcRh8EcDAwMP5AFzBtVXnOKcIs8f/jxJ6vQX+an+94Gvt/1bQuKF5zZ2ELS2LhOVLDz
+ XvZg5VjAwMAAt+A/4//Hl3bf2nfz1AOeL/e+bWNXZS5kYEBNSMzBrFwLJ3EKmrqwcgipM7No
+ nfj748ar//+vCbow8P/48t+XRZxRk+kDM9M/1n9ZXCpssh/Yvnchu0BGg4lZHsbRY2ZlE2Fg
+ cWRgYGD4+4PN6zfLHxdGDiZJxn9/bzFzMj3+cu7nKr4PaHkkio1r2zt+qf9/BWT+t3HyvRVn
+ YFBiYGBgYDBmYOWz5YjhteO0YgjFm/wZ+GxZ2Ds9WdhXq7CyWuBTSDUAANeVnXOvNaMbAAAA
+ AElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>smallObjectsIcon (in category 'private - icons') -----
+ smallObjectsIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallObjects'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallObjectsIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallObjectsIconContents (in category 'private - icons') -----
+ smallObjectsIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallObjects.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB/0lEQVR4nJWQXUgUURTH/zN3ZnMGbXcM+9AN
+ spaelETtQyLbsiWofAjspYwegggfpJ6KoqjH6KEEeyjDoBfFCvbBqChZiGJD7EMa66koQzPX
+ zf1o292ZuXN6aWSM2KYDl8s55///nXsuw+/wAfW1jO3LEsEGZvA/sVGSe64qgXm9YgXdVLTM
+ dubr92xeDmnrdTWQokCQnBNVl+VCjLV78YvVIsJ7JMXvLu6Uy1RNEHd5AiQEGn/LDcNdfG+b
+ dpZs/S96bUOtvGkRYIrz4cvFH09GedEiADo37bP5THzVga7pyMETDW5xS53v+Pq18i0AFU5N
+ cO56Ue5SBWzOEY3rttUDwAp3ngxJHI0kGyMjt69Rxw5lqO+M1tZ5YX6MCZT8PGu/8bImGuuq
+ hi8e0+bmHlYTxYNE8SDdOK1NhWqkFk8AAFq4SYl9uLfScgC7tyy5CwDMI6CwdF2EKoVPrYwJ
+ wkzSpi/frMLoO7NPWpA0tavgzLfIZso/MXHHiBzqbnv5YGhsIJc3++/nz3/PcL3KLx4GUOZ8
+ Iho6uqN7tzU3O3kqm2OPnr++tKay/IXAjcnHg70Jvx+r02l8dM9YeIHmL8epo/trnHzyawLP
+ XulBblM2Ntg7DQB/mgFALLW4ZSMfG7gyUUpTEkBE6VJ9wLXCbDIVbT1yLuVuZgrFp/8C/AKq
+ oMu3BdqijAAAAABJRU5ErkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>smallOkIcon (in category 'accessing - icons') -----
+ smallOkIcon
+
+ ^ Icons
+ at: #smallOkIcon
+ ifAbsentPut: [ self smallOkIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallOkIconContents (in category 'private - icons') -----
+ smallOkIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 248039624 79675327 33554431 33554431 33554431 33554431 33554431 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 16777215 16777215 16777215 16777215 2438055777 2135606620 16777215 16777215 33554431 33554431 33554431 33554431 33554431 33554431 50331647 50331647 50331647 50331647 61516458 2471741027 4285252467 4284989551 2034219344 16777215 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 2437793121 4285186674 4287618449 4286961290 4284332135 2066328132 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 2437923681 4285055344 4287487120 4287356046 4284397928 4281637445 134225920 33554431 33554431 1147794552 1718086006 33554431 33554431 33554431 33554431 2437792609 4284989551 4287290254 4287159181 4284332135 4231042883 134225920 16777215 196721081 1047000951 3865102958 4286107261 1885067371 33554431 33554431 2437792091 4284923758 4287224460 4287027851 4284266341 4230977347 152844572 61516458 93952409 1198060663 3831679084 4287027080 4287552399 4233345377 1884605796 2336866654 4284857964 4286962059 4286896264 4284069475 4230911554 152844572 33554431 33554431 33554431 169502259 4284334440 4285910139 4287684243 4286961546 4284990064 4285252723 4286764935 4286634375 4284003682 4247426367 152844572 33554431 33554431 33554431 33554431 33554431 186080558 4283676768 4285252979 4287159181 4287027594 4286568581 4286568325 4283806817 4264203071 171134259 50331647 33554431 33554431 33554431 33554431 33554431 33554431 186080535 4283018583 4284595563 4286634118 4286371460 4283741024 4264071742 152844572 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 186074647 4282229325 4284003683 4283544158 4263940413 152844572 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 186074647 4281243715 4213674302 136331296 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 186074647 136331296 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallOpenIcon (in category 'accessing - icons') -----
+ smallOpenIcon
+
+ ^ Icons
+ at: #smallOpenIcon
+ ifAbsentPut: [ self smallOpenIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallOpenIconContents (in category 'private - icons') -----
+ smallOpenIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 4167658343 4218055784 4234767207 4234833000 4234833000 4251741802 4251807595 3597825392 359492973 16777215 16777215 16777215 2676854157 3968633996 3968633996 3968633996 4285098855 4294572537 4294638330 4294704123 4294769916 4294769916 4294835709 4289835697 3782111083 242052461 16777215 16777215 4035677067 4292072403 4291940817 4291809231 4284967526 4292993505 4292598747 4292598747 4292598747 4292401368 4292269782 4294901502 4272202915 3563942253 158429553 16777215 4018570886 4291875024 4290690750 4290427578 4284967526 4293125091 4289506732 4289506732 4289506732 4289506732 4292730332 4294901502 4294835709 4272335015 2590863724 16777215 4001464705 4291611851 4290427578 4290295992 4285098855 4293454056 4293256677 4293190884 4293190884 4293190884 4293322470 4293783021 4293585642 4292467161 4050678382 16777215 3967647101 4291414473 4290295992 4290032820 4285098855 4293651435 4289704110 4289506731 4289506731 4289506731 4293190884 4293519849 4293519849 4292467417 4084101228 16777215 3950540920 4291085508 4290098613 4289835441 4285164648 4293914607 4293848814 4293848814 4293783021 4293783021 4293783021 4293783021 4293717228 4292927712 4050546540 16777215 3916591730 4290822336 4282744759 4281957047 4281957047 4281826232 4281759928 4281759928 4281628856 4281628855 4281628855 4281628855 4281563063 4281563063 4281563063 3828906425 3916394351 4290559164 4281628856 4291354096 4291354096 4291354096 4291354096 4291354096 4291354096 4291419632 4291419888 4291419888 4291419888 4291419888 4291025902 4264785848 3882445161 4290295992 4281628855 4291550960 4288463588 4288463588 4288463588 4288463588 4288463588 4288463588 4288463588 4288463588 4288463588 4288660965 4290894317 4247943351 3848561764 4290032819 4281759927 4291682288 4288857574 4288857574 4288857574 4288857574 4288857574 4288857574 4288857574 4288857574 4288857574 4288660709 4290893805 4214519992 3831389790 4289835441 4281825720 4291288047 4289054438 4288988902 4288988902 4288988902 4288988902 4288988902 4288988902 4288726245 4288331748 4288003810 4290434027 4197742776 3797572186 4289440683 4281957047 4289711337 4288200675 4287938018 4287609569 4287477985 4287346912 4287149791 4286821086 4286689758 4286689758 4286952670 4288725988 4164188600 3764083547 4289309097 4282088119 4288660196 4287412448 4287083999 4287083999 4287083999 4287083999 4287083999 4287083999 4287083999 4287083999 4287215583 4287609312 4147542200 3764017754 4287601320 4282088119 4284193486 4284259279 4284259279 4284259279 4284259279 4284259279 4284259279 4284259279 4284259279 4284259279 4284259279 4283404487 3644225976 2656459876 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 3996481463 1194293175)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallPaintIcon (in category 'private - icons') -----
+ smallPaintIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallPaint'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPaintIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallPaintIconContents (in category 'private - icons') -----
+ smallPaintIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallPaint.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB60lEQVR4nJXQT0iTcRzH8ffze/5srT0zNvqr
+ KM42JTskoRJISVARCf0RCTp4KCMhELpJx4gQomNBl+jgtX8QnQorqIyg/5atpZmOlk62PXPP
+ 9uCz5+kQ7bAObd/rh8+LD1+o8cJwIgzDgKi1S0Qw/Gi0wx0f3O62wAi1KG0Q6tu1/nLnnr3o
+ uh8JumoCXFmMjZze56eYxgYcyFQNNENTT7v/VKi1B4w5Vl0AFqoGBAwdP9IlIWuQX8SyS4hq
+ gV5QhMTJju6dsPwJcFk2TFyYrAr4AQd2tKzd4tkQhdQUpVVIpsylbxCvCpBgf19vM5hLkEtQ
+ tFzeTqfu/M2V/wKStNsQIV6+eMNWbN7FinxdyI3/AwyAvAbOBED9CFcfgw2gB4NqtP88iqZx
+ /d5dpiZuGrPwvAwcgnA9DM7Bg04YC4DPgM3AaBgiqrAablw6h+INkU1bzvRs9ixQKgNe8Ot/
+ kGPfYTIGFySYAVCFGDrYHq4reSQsJcur1x+exaE8H0Dcgvef4WIaMl7YdhSeKnA4At224yS0
+ lE1jRqHekPFpmlT5IwXAgTYVGppgXStIebjWHNy0uNGr1+krwowWPL77TpKcaV2pBGSAOHxp
+ hPwvMGMQL8D8z8KKFdACqt+W1du5+YmHyUT/DDypBH4Dwguh75kYJgEAAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>smallPasteIcon (in category 'accessing - icons') -----
+ smallPasteIcon
+
+ ^ Icons
+ at: #smallPasteIcon
+ ifAbsentPut: [ self smallPasteIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallPasteIconContents (in category 'private - icons') -----
+ smallPasteIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 33554432 3983042920 4286743170 4286743170 4286743170 4286743170 3983042920 33554432 16777215 16777215 16777215 16777215 16777215 1278376377 4281628855 4281628855 4281628855 4286677633 4289377716 4289378230 4289378230 4289377716 4286677633 4281628855 4281628855 4281628855 1278376377 16777215 138420224 4281628855 4289252074 4292537599 4287207318 4286874756 4288652194 4288717730 4288717730 4288586401 4286874756 4287206547 4292537599 4289252074 4281628855 71319552 524958216 4281628855 4292537599 4287207061 4294375158 4293651435 4291940817 4291940817 4291940817 4291940817 4293651435 4294440951 4287206290 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287270541 4294967295 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294967295 4287270798 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287270541 4294967295 4294309365 4291546572 4291546572 4291546572 4291546572 4294243828 4294967295 4287270798 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287270541 4294967295 4294309365 4294309365 4294309365 4294309365 4294243828 4294112499 4294967295 4287270798 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287270541 4294967295 4294309365 4291546572 4291546572 4291480779 4291480522 4293980656 4294967295 4287270798 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287270541 4294967295 4294309365 4294243828 4294178035 4294046449 4293980656 4293322983 4294967295 4287270798 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287270541 4294967295 4294243572 4294112242 4294046449 4293980656 4293257190 4292665053 4294967295 4287270798 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287270541 4294967295 4294046706 4293980656 4293915120 4292730846 4291744208 4291678672 4294967295 4287270798 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287270541 4294967295 4293980656 4293849327 4293191397 4291743951 4294967295 4294967295 4294967295 4287270798 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287270541 4294967295 4293783791 4293125861 4292138709 4291612622 4294967295 4294967295 4287270798 4292537599 4292537599 4281628855 273694720 524958216 4281628855 4292537599 4287076246 4294178035 4294901502 4294901502 4294901502 4294243828 4294835965 4287270798 4292537599 4292537599 4292537599 4281628855 273694720 138420224 4281628855 4289252074 4292537599 4287142553 4287468177 4287468177 4287468177 4287468177 4287468177 4292537599 4292537599 4292537599 4289252074 4281628855 71319552 16777215 1278376377 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 1278376377 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallPinIcon (in category 'accessing - icons') -----
+ smallPinIcon
+
+ ^ Icons
+ at: #smallPinIcon
+ ifAbsentPut: [ self smallPinIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallPinIconContents (in category 'private - icons') -----
+ smallPinIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1560237654 2550092884 872371541 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1560237654 4294923605 4294923605 4294923605 1560237654 16777215 16777215 16777215 16777215 4294923605 16777215 16777215 16777215 16777215 16777215 1560237654 4294923605 4294923605 4294936712 4294936712 4294923605 1560237654 16777215 16777215 16777215 4294923605 4294923605 16777215 16777215 16777215 1560237654 4294923605 4294923605 4294936712 4294936712 4294923605 4294923605 4294923605 872371541 16777215 16777215 1560237654 4294923605 4294923605 1560226346 2113885782 4294923605 4294923605 4294936712 4294936712 4294923605 4294923605 4294923605 4293283149 2550092884 16777215 16777215 16777215 2113885782 4294923605 4294923605 4294923605 4294923605 4294936712 4294936712 4294923605 4294923605 4294923605 4293283149 4291576900 2107979575 16777215 16777215 16777215 16777215 2902410822 4294923605 4294923605 4294936712 4294936712 4294923605 4294923605 4294923605 4293283149 4291576900 2107979575 16777215 16777215 16777215 16777215 16777215 872371541 3187614499 4294923605 4294923605 4294923605 4294923605 4294923605 4293283149 4291576900 2107979575 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1560237654 3405717793 4294923605 4294923605 4294923605 4293283149 4291576900 2107979575 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3212409209 4286151033 3405717793 4294923605 4294923605 4291773765 2545302845 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3212409209 4286151033 3212409209 1560237654 3187614499 4294923605 4294923605 1560226346 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3212409209 4286151033 3212409209 16777215 16777215 872371541 2902410822 4294923605 4294923605 16777215 16777215 16777215 16777215 16777215 16777215 2675472504 4286151033 3212409209 16777215 16777215 16777215 16777215 16777215 2113885782 4294923605 4294923605 16777215 16777215 16777215 16777215 2138601592 4286151033 2675472504 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1560237654 4294923605 4294923605 16777215 16777215 16777215 4286151033 2138601592 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallPrintIcon (in category 'accessing - icons') -----
+ smallPrintIcon
+
+ ^ Icons
+ at: #smallPrintIcon
+ ifAbsentPut: [ self smallPrintIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallPrintIconContents (in category 'private - icons') -----
+ smallPrintIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2176367288 4290296247 4290296247 4290296247 4290296247 4290296247 4290296247 4290296247 4290296247 4290296247 2176367288 16777215 16777215 16777215 16777215 16777215 4290296247 4294638330 4294638330 4294638330 4294638330 4294638330 4294638330 4294638330 4294638330 4294572537 4290296247 16777215 16777215 16777215 16777215 16777215 4290296247 4294638330 4291809231 4291809231 4291809231 4291809231 4291809231 4291809231 4291809231 4294572537 4290296247 16777215 16777215 16777215 16777215 16777215 4290296247 4294638330 4294243572 4294243572 4294243572 4294309365 4294309365 4294309365 4294309365 4294572537 4290296247 16777215 16777215 16777215 16777215 16777215 4290296247 4294572537 4291809231 4291809231 4291875024 4291875024 4291875024 4291940817 4291940817 4294572537 4290296247 16777215 16777215 16777215 16777215 16777215 4290296247 4294572537 4293322470 4293454056 4293519849 4293519849 4293585642 4293651435 4293717228 4294572537 4290296247 16777215 16777215 16777215 16777215 16777215 4290296247 4294506744 4289835441 4289835441 4289835441 4289967027 4293388263 4293388263 4293388263 4294572537 4290296247 16777215 16777215 16777215 2173603982 4287598991 4288125078 4290361785 4290295992 4290361785 4290361785 4290361785 4290361785 4290361785 4290295992 4290295992 4288125078 4287598991 2173603982 16777215 4287598991 4294835709 4294638330 4294375158 4294375158 4294375158 4294375158 4294375158 4294375158 4294375158 4294375158 4294375158 4293651435 4293783021 4287598991 16777215 4287598991 4294835709 4292664540 4294046193 4290559164 4294309365 4293256677 4293519849 4293388263 4293454056 4293322470 4293125091 4289703855 4292335317 4287598991 16777215 4287598991 4294177779 4292269525 4293190884 4293190884 4293190884 4293190884 4293190884 4293125091 4293190884 4293190884 4292927712 4288585116 4291875024 4287598991 16777215 4287598991 4294309365 4291480266 4288190358 4287466635 4287466635 4287203463 4287334792 4287203205 4286940290 4287071877 4287334792 4290756543 4291875024 4287598991 16777215 4287598991 4294309365 4291282887 4291151301 4291151301 4291151301 4291151301 4291151300 4291019715 4290822336 4290953922 4291085508 4291151301 4291940817 4287598991 16777215 4287598991 4293980400 4292861919 4292927712 4292927712 4292861919 4292861919 4292861919 4292861919 4292861919 4292730333 4292861919 4292796126 4292664540 4287598991 16777215 2811269520 4287598991 4287598991 4287598991 4287598991 4287598991 4287598991 4287598991 4287598991 4287598991 4287598991 4287598991 4287598991 4287598991 2811269520)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectBackIcon (in category 'accessing - icons') -----
+ smallProjectBackIcon
+
+ ^ Icons
+ at: #smallProjectBackIcon
+ ifAbsentPut: [ self smallProjectBackIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectBackIconContents (in category 'private - icons') -----
+ smallProjectBackIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 2083747767 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 2083747767 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292537599 4292537599 4293176763 4293176763 4292537599 4292537599 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292537599 4292985039 4293751676 4293751676 4292985039 4292537599 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292793830 4293496216 4294901760 4294901760 4293496216 4292793830 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292985039 4294901760 4294901760 4294901760 4294901760 4292985039 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4290694609 4287727293 4287727293 4290694609 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4287595701 4281014002 4281014002 4287661239 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4287463852 4280948465 4280948465 4287464110 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4290628297 4287595700 4287595700 4290628298 4292537599 4281628855 16777215 16777215 2083747767 4291090666 4284271650 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 2083747767 16777215 16777215 3169845236 4278231040 4278231040 3053453311 3053453311 3053453311 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3053453311 4284271650 4289589680 4278231040 4278231040 4278231040 4278231040 3053453311 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281118976 4283491340 4278248192 4278247936 4278246144 4278244352 4278231040 3053453311 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3053453311 4281118976 4285526614 4278231040 4278231040 4278231040 4278231040 3053453311 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3169910772 4278231040 4278231040 3053453311 3053453311 3053453311 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectIcon (in category 'accessing - icons') -----
+ smallProjectIcon
+
+ ^ Icons
+ at: #smallProjectIcon
+ ifAbsentPut: [ self smallProjectIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectIconContents (in category 'private - icons') -----
+ smallProjectIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2083747767 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 2083747767 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292537599 4292537599 4293176763 4293176763 4292537599 4292537599 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292537599 4292985039 4293751676 4293751676 4292985039 4292537599 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292793830 4293496216 4294901760 4294901760 4293496216 4292793830 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292985039 4294901760 4294901760 4294901760 4294901760 4292985039 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4290694609 4287727293 4287727293 4290694609 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4287595701 4281014002 4281014002 4287661239 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4287463852 4280948465 4280948465 4287464110 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4290628297 4287595700 4287595700 4290628298 4292537599 4281628855 16777215 16777215 2083747767 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 2083747767 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectJumpIcon (in category 'accessing - icons') -----
+ smallProjectJumpIcon
+
+ ^ Icons
+ at: #smallProjectJumpIcon
+ ifAbsentPut: [ self smallProjectJumpIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectJumpIconContents (in category 'private - icons') -----
+ smallProjectJumpIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 2083747767 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 2083747767 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292537599 4292537599 4293176763 4293176763 4292537599 4292537599 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292537599 4292985039 4293751676 4293751676 4292985039 4292537599 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292793830 4293496216 4294901760 4294901760 4293496216 4292793830 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292985039 4294901760 4294901760 4294901760 4294901760 4292985039 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4290694609 4287727293 4287727293 4290694609 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4287595701 4281014002 4281014002 4287661239 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4287463852 4280948465 4280948465 4287464110 4292537599 4281628855 16777215 16777215 4281628855 4292537599 4278239744 4278239744 4278239744 4278239744 4292537599 4292537599 4290628297 4287595700 4287595700 4290628298 4292537599 4281628855 16777215 16777215 2083747767 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4284271650 4291090666 2083747767 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3053453311 3053453311 3053453311 4278231040 4278231040 3500729258 16777215 16777215 1275109632 4278231040 1275109632 4278231040 1275109632 4278231040 1275109632 3053453311 4278231040 4278231040 4278231040 4278231040 4278241792 4278231040 3417498546 16777215 4278231040 4278246144 4278231040 4278246144 4278231040 4278246144 4278231040 3053453311 4278231040 4278246144 4278246144 4278246144 4278246144 4278241792 4278231040 16777215 1275109632 4278231040 1275109632 4278231040 1275109632 4278231040 1275109632 3053453311 4278231040 4278231040 4278231040 4278231040 4278241792 4278231040 3417498546 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3053453311 3053453311 3053453311 4278231040 4278231040 3500729258 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectLoadIcon (in category 'accessing - icons') -----
+ smallProjectLoadIcon
+
+ ^ Icons
+ at: #smallProjectLoadIcon
+ ifAbsentPut: [ self smallProjectLoadIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectLoadIconContents (in category 'private - icons') -----
+ smallProjectLoadIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 1278376377 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 1278376377 16777215 16777215 16777215 16777215 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4294928966 4294928966 4292537599 4292537599 4292537599 4281628855 16777215 16777215 16777215 16777215 4281628855 4281628855 4281628855 4292537599 4292537599 4294949256 4294901760 4294901760 4294949256 4292537599 4292537599 4281628855 16777215 16777215 1412725174 4281628855 4281628855 4287412967 4281628855 4288923367 4292537599 4294933841 4294901760 4294901760 4294933841 4292537599 4292537599 4281628855 16777215 1412725174 4281628855 4290304767 4290304767 4290304767 4287412967 4281628855 4278247936 4278247936 4292537599 4292537599 4290947299 4290947299 4292537599 4281628855 16777215 4281628855 4290304767 4287412967 4281628855 4287412967 4281628855 4279353404 4278247936 4278247936 4292537599 4290947299 4282515711 4282515711 4290947299 4281628855 16777215 4281628855 4290304767 4281628855 4281628855 4281628855 4281628855 4278247936 4278247936 4278247936 4292537599 4290947299 4282515711 4282515711 4290947299 4281628855 16777215 4281628855 4281628855 4281628855 16777215 16777215 1278376377 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 1278376377 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4294770683 4294770683 4294770683 4294770683 4294770683 4294770683 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4294770683 4294770683 4294770683 4294770683 4294770683 4294770683 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4294770683 4294770683 4294770683 4294770683 4294770683 4294770683 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4294770683 4294770683 4294770683 4294770683 4294770683 4294770683 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectNextIcon (in category 'accessing - icons') -----
+ smallProjectNextIcon
+
+ ^ Icons
+ at: #smallProjectNextIcon
+ ifAbsentPut: [ self smallProjectNextIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectNextIconContents (in category 'private - icons') -----
+ smallProjectNextIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 3178078063 4282619024 4282619024 4282619024 4282619024 4282619024 4282619024 4282619024 4282619024 4282619024 4282619024 4282619024 4282619024 3178078063 16777215 16777215 4282619024 4292666586 4292666586 4292666586 4292666586 4292666586 4294159759 4294159503 4292666586 4292666586 4292666586 4292666586 4292600791 4282619024 16777215 16777215 4282619024 4292666587 4292337348 4292337348 4292337348 4293637757 4294139970 4294139970 4293571966 4292271812 4292271812 4292337350 4292600791 4282619024 16777215 16777215 4282619025 4292666589 4292337349 4292337349 4292337349 4294079056 4294901760 4294901760 4294079056 4292337349 4292337349 4292271812 4292600790 4282619024 16777215 16777215 4282619025 4292732381 4292337608 4292337608 4292337608 4294901760 4294901760 4294901760 4294901760 4292337350 4292271810 4292271553 4292600791 4282619024 16777215 16777215 4282619025 4292666586 4292337609 4285977428 4285977170 4285911632 4285911631 4292271554 4291084195 4287727293 4287727293 4291084196 4292534996 4282619024 16777215 16777215 4282619025 4292469200 4292140219 4278239744 4278239744 4278239744 4285713988 4292074168 4287595701 4281014002 4281014002 4287661239 4292337610 4282619024 16777215 16777215 4282619025 4292140221 4291942577 4278239744 4278239744 4278239744 4285582397 4291942577 4287463852 4280948465 4280948465 4287464110 4292140221 4282619024 16777215 16777215 4282619026 4292074170 4292074167 4278239744 4278239744 4278239744 4285713987 4292074167 4290886292 4287595700 4287595700 4290886293 4292073912 4282619024 16777215 16777215 4282619026 4291415968 4291415968 4291415968 4291415968 4291415968 4291415968 4291415968 4291415968 4291415968 4284271650 4293915107 4291153049 4282619024 16777215 16777215 3178078063 4282619024 4282619024 4282619024 4282619024 4282619024 4282619024 4291354847 4291354847 4291354847 4278231040 4278231040 4290962394 3178078063 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3053453311 4278231040 4278231040 4278231040 4278231040 4289589680 4284271650 3053453311 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3053453311 4278231040 4278244352 4278246144 4278247936 4278248192 4283491340 4281118976 3053453311 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3053453311 4278231040 4278231040 4278231040 4278231040 4285526614 4281118976 3053453311 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3053453311 3053453311 3053453311 4278231040 4278231040 3169910772 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281118976 3053453311 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectSaveIcon (in category 'accessing - icons') -----
+ smallProjectSaveIcon
+
+ ^ Icons
+ at: #smallProjectSaveIcon
+ ifAbsentPut: [ self smallProjectSaveIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallProjectSaveIconContents (in category 'private - icons') -----
+ smallProjectSaveIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 1278376377 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 1278376377 16777215 16777215 16777215 16777215 16777215 16777215 4281628855 4292537599 4292537599 4292537599 4294928966 4294928966 4292537599 4292537599 4292537599 4281628855 16777215 16777215 16777215 16777215 16777215 16777215 4281628855 4292537599 4292537599 4294949256 4294901760 4294901760 4294949256 4292537599 4292537599 4281628855 16777215 16777215 16777215 16777215 16777215 16777215 4281628855 4292537599 4292537599 4294933841 4294901760 4294901760 4294933841 4292537599 4292537599 4281628855 16777215 16777215 16777215 16777215 16777215 16777215 4281628855 4278247936 4278247936 4278247936 4292537599 4292537599 4290947299 4290947299 4292537599 4281628855 16777215 4281628855 4281628855 1412725174 16777215 16777215 4281628855 4278247936 4278247936 4278247936 4292537599 4290947299 4282515711 4282515711 4290947299 4281628855 16777215 4281628855 4290304767 4281628855 1412725174 16777215 4281628855 4278247936 4278247936 4278247936 4292537599 4290947299 4282515711 4282515711 4290947299 4281628855 16777215 4281628855 4287412967 4290304767 4281628855 16777215 1278376377 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 4281628855 1278376377 16777215 16777215 4281628855 4290304767 4281628855 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281628855 4281628855 4290304767 4281628855 4281628855 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4286151288 4286151288 4281628855 4287412967 4290304767 4287412967 4281628855 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4294770683 4294770683 4290434020 4281628855 4287412967 4281628855 4284643980 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4294770683 4294770683 4294770683 4290434020 4281628855 4290434020 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4294770683 4294770683 4294770683 4294770683 4294770683 4294770683 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4294770683 4294770683 4294770683 4294770683 4294770683 4294770683 4286151288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288 4286151288)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallPublishIcon (in category 'private - icons') -----
+ smallPublishIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallPublish'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPublishIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallPublishIconContents (in category 'private - icons') -----
+ smallPublishIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallPublish.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADG0lEQVQ4jY2Sb2jUdQDGP9/fn7vN29+7tv2c
+ t5tenulsUd1miWlEFCjZzRdRVPiiEnohBBaLIiRIg9heDAuiFwVJONgcWrBilajlKlKU5cEa
+ zrlluzvnbfd/9/f3/fYiKgoOel4/z4cHnkfwP7Tl4X2PSanvEeBXyCkp1PC1705NA4h/Obfi
+ oMU8R6fLQzi5H/9Tl+6+rT7b3Nn4RK63Lxap73LZ878sVc6NNqhycWjmwtgx/e9wkG4cvM2T
+ vr5nB171zPiSL3gmbgeeeyjwzIcHLWf7XRvdzzddrf+hZa9V3ravwb48scnjvTOsE8R0Pej5
+ eus7oYH0675guUcn7IzTGLDE8tpE99D6dmFaXUTjgu1101wvdjAj12rC11WSV852GMChbe89
+ /ehZbRy+SkuUlCrkMlYSNxC/RVh0P0Kdqmd4+T70smRBNrO9McLSmlYrLES3galtDnsXYSxt
+ M5TowGsexrr8MhP2zc7JHkfh8M62QGUKZ/NO3sr2MbnlA0gvk8gpHq/RShoV+X08lgS30pFU
+ iJf7eS3h52jaVyM9M0em10XHY/dwJdNK3jYoFAVfxO7njRG1ksmXRzTyjKjha1FWAEEjk2T4
+ mRt/TiRfKp4ctN+c8kWKUueA5yJOmWHwTGrh/E+zN+26/FFxoIfdjpaOY7hb3Tu6g9Lpcmmm
+ oQtNEyCEmJu/pY5fiIqcozXV1lzrKK/mGlK50qlVQxyc+3Y0ZRiGufv98amNQiVAFliKzDJ3
+ 8ThSr6d3VwhTt7HuOK8Ojcbay6vZ9tl15jzjJ+2/1jdavAFfIrlEPFkCVaFGGBTzaeoaHZh6
+ BWSB2lpd/f7jaB64/t+XGu42r5XKJKnYLYCipBbZFXoFoQokUnFqTYXDIWS1mxuFbHp1g+Ui
+ uzLHrx+fxtXrR7StZ/+nQxhK0NHkYgf3qmoAbfnWQgTg6okvCQ5+TnRgDGkXiMbiWKzBUIpS
+ SaveIBWPRjKpEr0vhrjU2syG4CaE3sQ3/e+CLIDWwEdHPslVBSjBif69D/iVbetK/dNUMwxh
+ mk7NcNSI1WzydDXAH4NwUmsvAPcyAAAAAElFTkSuQmCC'!
Item was added:
+ ----- Method: MenuIcons class>>smallQuitIcon (in category 'accessing - icons') -----
+ smallQuitIcon
+
+ ^ Icons
+ at: #smallQuitIcon
+ ifAbsentPut: [ self smallQuitIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallQuitIconContents (in category 'private - icons') -----
+ smallQuitIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 4284901482 4290098613 4288124823 4287401100 4286677377 4286085240 4285558896 4285295724 4294046194 4294112244 4294309366 4294440952 4294440952 4293980658 4287598995 679904902 4284901482 4290493371 4288585374 4287730065 4287137928 4286545791 4286019447 4285756275 4294046194 4294309365 4294572537 4294704124 4294769916 4294638330 4289243563 1066044042 4284901482 4291217094 4289111718 4288387995 4287664272 4287137928 4286677377 4286282619 4294046194 4294309366 4294638330 4288727272 4282685399 4294704123 4289769906 1183484554 4284901482 4291282887 4289572269 4289045925 4288387995 4287730065 4287203721 4286808963 4294046451 4294112502 4285771742 4284261853 4278219466 4292536564 4288260277 1736008038 4284901482 4291414473 4289769648 4289243304 4288716960 4288190616 4287664272 4287203721 4293324017 4282553556 4285444580 4289977081 4281306583 4280321491 4279467214 4278544569 4284901482 4291480266 4289835441 4289374890 4288848546 4288322202 4287795858 4286351764 4279335885 4285707496 4288007672 4288401400 4288861177 4288926713 4289189626 4278348735 4284901482 4291480266 4289967027 4289506476 4288980132 4288519581 4285894306 4278218436 4285182955 4285906421 4283345650 4283542770 4283674098 4283805170 4288335864 4278348992 4284901482 4291480266 4290164406 4289638062 4289177511 4288585374 4278217663 4281832927 4284527603 4280522222 4278946541 4278224107 4278224106 4278224364 4286300406 4278348992 4284901482 4291480266 4290295992 4289835441 4289243304 4288716960 4286944417 4278217920 4280782815 4281638640 4278223849 4278223849 4278223849 4278224106 4284133619 4278348735 4284901482 4291480266 4290295992 4289901234 4289374890 4288914339 4288387995 4287337370 4280057289 4279600088 4281835503 4282689009 4282097645 4282294251 4282425579 4278348735 4284901482 4291480266 4290295992 4290032820 4289572269 4289111718 4288716960 4287927444 4285625720 4283604181 4278220498 4281572332 4278218436 4278482381 4278218435 4079241345 4284901482 4291480266 4290295992 4290295992 4289835441 4289309097 4286743170 4288322460 4292467419 4293454314 4286230746 4278219466 4278218951 4293520107 4288190874 814056837 4284901482 4291480266 4290361785 4290624957 4288124824 4288454561 4291875283 4292533470 4292730592 4292796385 4292862178 4288002776 4283209424 4292665056 4286875272 495223940 4284901482 4291743438 4289177769 4288783012 4291283661 4291612369 4291743954 4291743955 4291809747 4291809747 4291809747 4291809747 4291809747 4291612626 4285690998 176193664 3309849418 4286282878 4284967275 4285033068 4285098861 4285098861 4285098861 4285098861 4285164654 4285164654 4285164654 4285164654 4285164654 4285098861 3326889805 41975936 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallQuitNoSaveIcon (in category 'accessing - icons') -----
+ smallQuitNoSaveIcon
+
+ ^ Icons
+ at: #smallQuitNoSaveIcon
+ ifAbsentPut: [ self smallQuitNoSaveIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallQuitNoSaveIconContents (in category 'private - icons') -----
+ smallQuitNoSaveIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 4284967526 4290098613 4288124823 4287401100 4286677377 4286085240 4285558896 4285295724 4294111985 4294243570 4294375157 4294506743 4294506743 4293980912 4287730575 369098751 4284967526 4290493371 4288585374 4287730065 4287137928 4286545791 4286019447 4285756275 4294111985 4294309365 4294572537 4294769915 4294769916 4294638330 4289375144 587202559 4284967526 4291217094 4289111718 4288387995 4287664272 4287137928 4286677377 4286282619 4294111985 4294375157 4294638330 4293435552 4292297797 4294704123 4289835696 654311423 4284967526 4291282887 4289572269 4289045925 4288387995 4287730065 4287203721 4286808963 4294177777 4294374642 4292768627 4292697180 4291428352 4294237146 4290091673 988390307 4284967526 4291414473 4289769648 4289243304 4288716960 4288190616 4287664272 4287203721 4294043878 4292100674 4293160558 4294554547 4292292400 4292026402 4291695379 4173529088 4284967526 4291480266 4289835441 4289374890 4288848546 4288322202 4287795858 4287921276 4291629331 4293423730 4294481302 4294482843 4294550178 4294550435 4294616999 4240637952 4284967526 4291480266 4289967027 4289506476 4288980132 4288519581 4288836982 4291035136 4293618282 4294276470 4294069839 4294070609 4294071124 4294071637 4294482586 4240703488 4284967526 4291480266 4290164406 4289638062 4289177511 4288585374 4290707456 4292818744 4294140000 4293796644 4293724943 4293591040 4293525504 4293656576 4294343547 4240703488 4284967526 4291480266 4290295992 4289835441 4289243304 4288716960 4288775557 4290772992 4292814633 4293932085 4293459968 4293459968 4293459968 4293525504 4294138458 4240637952 4284967526 4291480266 4290295992 4289901234 4289374890 4288914339 4288387995 4288318347 4291370268 4292351255 4293867320 4294001733 4293737276 4293606975 4293607489 4257415168 4284967526 4291480266 4290295992 4290032820 4289572269 4289111718 4288716960 4287927444 4286083697 4292170578 4291952640 4293669684 4291035136 4291625991 4290969600 3368550400 4284967526 4291480266 4290295992 4290295992 4289835441 4289309097 4286743170 4288388250 4292467673 4293520104 4292508538 4291428352 4291231744 4293585897 4288256664 436207615 4284967526 4291480266 4290361785 4290624957 4288125079 4288586140 4291941328 4292665050 4292796637 4292862430 4292928223 4292384661 4291841612 4292731100 4287006852 268435455 4284967526 4291743438 4289243559 4288914593 4291415495 4291678668 4291875534 4291875790 4291875791 4291875791 4291875791 4291875791 4291875791 4291809996 4285822578 100663295 2238541675 4286348923 4285098855 4285164648 4285230441 4285230441 4285230441 4285230441 4285296234 4285296234 4285296234 4285296234 4285296234 4285230441 2255647856 33554431 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallRedoIcon (in category 'accessing - icons') -----
+ smallRedoIcon
+
+ ^ Icons
+ at: #smallRedoIcon
+ ifAbsentPut: [ self smallRedoIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallRedoIconContents (in category 'private - icons') -----
+ smallRedoIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4282691328 860270336 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4282691328 4282691328 1128640256 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4282691328 4289526392 4282691328 1094955264 16777215 16777215 16777215 16777215 16777215 16777215 16777215 122271232 1178971904 2655301120 3477384960 4282691328 4282691328 4289526392 4289526392 4282691328 1094955264 16777215 16777215 16777215 16777215 16777215 910339840 2974068224 3298668032 3719096654 4289591414 4289591671 4289919871 4289001324 4285128704 4289526392 4282691328 1094955264 16777215 16777215 16777215 1246081024 3359944448 4256228425 4289722227 4288737880 4288866048 4288866048 4288866048 4288866048 4285128704 4285128704 4289526392 4282691328 998676224 16777215 725725696 3125128960 4289586251 4289853296 4289128704 4288080156 4288866048 4288866048 4290044672 4285128704 4285128704 4285128704 4285260032 4289526392 4282691328 16777215 2655301120 3936735531 4289852778 4289194502 4290044672 4290044672 4291877888 4285586944 4285128704 4285128704 4285128704 4285128704 4286901554 4282691328 1094955264 16777215 3662721792 4289917550 4290701860 4292009728 4288537088 4288931328 4288931328 4288931328 4288931328 4292864000 4285128704 4286901554 4282691328 1094955264 16777215 16777215 4048204032 4289983599 4292141312 4272009984 4282691328 4282691328 4282691328 4282691328 4282691328 4292075264 4286901554 4282691328 1094955264 16777215 16777215 16777215 4282691328 4290964552 4289116160 4047810304 1933946624 809873152 16777215 16777215 4282691328 4286901554 4282691328 1094955264 16777215 16777215 16777215 16777215 4282691328 4256752690 4282691328 1212395008 16777215 16777215 16777215 16777215 4282691328 4282691328 860270336 16777215 16777215 16777215 16777215 16777215 4282691328 4122863670 4265914112 16777215 16777215 16777215 16777215 16777215 4282691328 860270336 16777215 16777215 16777215 16777215 16777215 16777215 3242438144 3333936384 3466506240 1212395008 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1581559808 2253699584 2529681430 2359929600 205564416 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 541634304 1782820864 1531162112 491171840 79675136 61516288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallRemoteOpenIcon (in category 'private - icons') -----
+ smallRemoteOpenIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallRemoteOpen'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallRemoteOpenIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallRemoteOpenIconContents (in category 'private - icons') -----
+ smallRemoteOpenIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallRemoteOpen.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAYAAABWzo5XAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAD2klEQVQ4ja3T+0/VdRzH8efn+/18OTcOnJtc
+ zhFCg+EVD56BiYU4qQw1XdocttSt6VrL1fyh1vpBN7dq9mPZlv1Wm1OsDRZqU/DSkKkFelKS
+ wEsonANM1AOHw/d7Lt/TD9lWW2219f4DHnu/fnjC/3RidzkWIx+r1MkkLcxVBDcO9ZD6r5A0
+ 8jiTY7XWyTzNrG9aq4TPnU/sDEXbEHwjspw81EPiX320K0T7gfbWtWORcc61tFBSWUnZwoX0
+ dnTQ09k5E4/FjitZvlYNjn/WR/yfIDUUYGFDrfpMyawEoRe3YySh5cAH7HpvG2t2vq2VLapa
+ kM2am8fHRvYsKcjU1BQjQ36GeqIYf4GWFuGrCC56uTjvEUz0UlBRzVRCYWqgk1JLmCJvhlBD
+ Hat3vCGL5lTMM/SZlx5Eo3uW+rO1NX76f4wwCqAuC5B2eArfXFw1G0QOZE0cpTV8d/QEoWXl
+ qGYCpm4jH1yixC956oXnWbl1l2pzuipvhsM7gn6zpXeECXVdhIfj7vQ79WtWaD/fy9AVjhET
+ RXiLA5w6doaxsQROtxun2w3pBEzexDJ1lYrqJVh88+T17ou23ijfyn1gNg/Hr2zeN1SXVG3k
+ BOZgvznKSH+E5cGNNK4OcPnCKUZb+ygpyadpQxCRTYE+wRPz5xM3RDnkeuXip7e6b9mM4Meb
+ illWW8prt5p5zjXBkChjuO0TPj38Awf3b0M4Z3O96zxHDrfSvH0lCAuqlAAapOcraWVm/871
+ flv9AgsXp5/kfVcb613XyAhJcMtb9EcFHae7IdLFouXLyS9dwODtSVCsKFKigAbZHMVplWub
+ an1i2l7EsbtzqbRH0UhimJCjKpStWMWFn6ZAOiA+QsOWV+i5fAe0PKQqEAIVMGU6K9xfjDey
+ t+AsxZ4Mtbfe5dlZD9jt78KuqkzmjjE0LDBMK5Z0EnuuxO4pQk/noKgqQkGCMJT4tNF3YsKj
+ p5IKm51XMYXCptyL+Geu4IqdJXZviEKvHc2WD5oD9Bh1GzYS7hlAVSWCx1AmlTo62XZwbN2d
+ 1/loaAUAg7qLG/dtNHc3cvpKjODiEhRL7u/zEPgKvDg8hSjyD0hJqg8jg5dcroIN8TsD6fvl
+ q1xznLrY62sl/MtE9qtD7Y/kve5f49c6s+N3hx0zehprngdHfh4Ojw9D1+k40vIoPCq+FI9T
+ sZZWNXxoc3k3qtKSa5OmLZVMDURu931+/27/CWCkrkyr8lozTXY1Wx8I+JZWVi+ZZZom506e
+ /f7odeur4k/dCSCgaZovlUpJIAZE4e+Kz3dXFU5Xq6oouzGuDupp/fJvhgd0/Din8aMAAAAA
+ SUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>smallRightFlushIcon (in category 'accessing - icons') -----
+ smallRightFlushIcon
+
+ ^ Icons
+ at: #smallRightFlushIcon
+ ifAbsentPut: [ self smallRightFlushIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallRightFlushIconContents (in category 'private - icons') -----
+ smallRightFlushIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 2862522779 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 4288257175 2862522779 16777215 16777215 4288257175 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4289638062 4289440683 4289440683 4289440683 4289440683 4289440683 4289440683 4294440950 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294440950 4294440950 4294440950 4294440950 4294440950 4294440950 4294440950 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4289638062 4289440683 4289440683 4289440683 4289440683 4294309365 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294440950 4294440950 4294440950 4294375157 4294309365 4294440950 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4294572537 4294572537 4294572537 4294572536 4294506743 4294440950 4294375157 4294309365 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572537 4289440683 4289309097 4289309097 4289309097 4289309097 4289309097 4289309097 4294309364 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572537 4294572536 4294375157 4294309365 4294309364 4294243571 4294177778 4294111985 4294046193 4294177779 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294572536 4294506743 4294440950 4294375157 4294309365 4294309365 4294243572 4294177779 4294177778 4294111985 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294440950 4294375158 4294309365 4294309365 4294309364 4289440683 4289309097 4289309097 4289309097 4293848814 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294375157 4294309365 4294309364 4294243571 4294177779 4293980400 4293914607 4293848814 4293783021 4293980399 4294901502 4288454554 16777215 16777215 4288257175 4294967295 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294967295 4288454554 16777215 16777215 2862522779 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 4288454554 2862522780 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallSaveAsIcon (in category 'accessing - icons') -----
+ smallSaveAsIcon
+
+ ^ Icons
+ at: #smallSaveAsIcon
+ ifAbsentPut: [ self smallSaveAsIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallSaveAsIconContents (in category 'private - icons') -----
+ smallSaveAsIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 2088343690 2119535780 1866038431 2352512158 3560536991 4281957279 4165041566 3847390612 2237959310 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1581744805 2120722634 1569307355 3451508718 4292273651 4291617521 4288990696 4252212658 4249387676 461084520 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4287143846 4285694857 4283662745 4282615725 4282813362 4289252322 4291355120 4283799744 4284120721 4286677886 4286677886 4286677886 4286677886 4287796623 16777215 16777215 4287534739 4294967295 4293126109 4291944164 4286032581 4281957279 4289975786 4288464094 4284256430 4292601323 4294967295 4294967295 4294967295 4287862160 16777215 16777215 4287994512 4294046193 4294046193 4293257444 4286818752 4281957279 4286756567 4288266713 4282416802 4290234575 4294046193 4293980657 4293980657 4287862160 16777215 16777215 4287862160 4293914864 4281957279 4281957279 4281957279 4281957279 4286756567 4284195788 4281957279 4281957279 4281957279 4281957279 4293980400 4287862160 16777215 16777215 4287862160 4293783022 4292073678 4281957279 4288793573 4286230477 4286230477 4286230477 4286361550 4288661474 4281957279 4288854206 4293848558 4287862160 16777215 16777215 4287862160 4294704123 4293519849 4291810762 4281957279 4288793573 4286361550 4286361550 4290040551 4281957279 4288656827 4293519849 4294375158 4287862160 16777215 16777215 4287862160 4294046193 4294704123 4293519849 4291810762 4281957279 4290106858 4288793573 4282154659 4288656827 4293519849 4294704123 4294046193 4287862160 16777215 16777215 4287862160 4293519849 4294046193 4294704123 4294704123 4292271570 4282613922 4281957279 4289182914 4294704123 4294835709 4294046193 4293519849 4287862160 16777215 2158208927 4289901488 4289835952 4289901488 4289901488 4289901488 4289901488 4289901488 4289901488 4289901488 4289901488 4289901488 4289901488 4289901488 4289901488 2158208927 4286677886 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4278190080 4294967295 4294967295 4286677886 4286677886 4294967295 4290625211 4294967295 4290625212 4294967295 4290625211 4294967295 4290625211 4294967295 4291085763 4294967295 4278190080 4294967295 4294967295 4286677886 4286677886 4294967295 4291085763 4294967295 4291085763 4294967295 4291085763 4294967295 4291085763 4294967295 4291085763 4294967295 4278190080 4294967295 4294967295 4286677886 4286677886 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4278190080 4294967295 4294967295 4286677886 2155971454 4286677886 4286677886 4286677886 4286677886 4286677886 4286677886 4286677886 4286677886 4286677886 4286677886 4286677886 4286677886 4286677886 4286677886 2155971454)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallSaveIcon (in category 'accessing - icons') -----
+ smallSaveIcon
+
+ ^ Icons
+ at: #smallSaveIcon
+ ifAbsentPut: [ self smallSaveIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallSaveIconContents (in category 'private - icons') -----
+ smallSaveIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 2089200540 2119802550 1865322161 2351730865 3559886514 4281306802 4164849841 3847723431 2238554017 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1581749686 2120857815 1569835238 3451969523 4292602614 4292012277 4289452015 4252872386 4249392559 461679227 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4287999926 4286748316 4284126380 4282227390 4282424771 4289779178 4291749876 4283738575 4284780964 4287862160 4287862160 4287862160 4287862160 4288849568 16777215 16777215 4288587684 4294967295 4293455075 4292404714 4286495186 4281306802 4290436848 4288991207 4284654271 4292930288 4294967295 4294967295 4294967295 4288980641 16777215 16777215 4289047457 4294243572 4294243572 4293586409 4287477965 4281306802 4287218657 4288859618 4282159540 4290892761 4294243572 4294178036 4294178036 4288980641 16777215 16777215 4288980641 4294112243 4281306802 4281306802 4281306802 4281306802 4287218657 4284068825 4281306802 4281306802 4281306802 4281306802 4294177779 4288980641 16777215 16777215 4288980641 4294046193 4292534487 4281306802 4289254892 4286693081 4286693081 4286693081 4286823898 4289188586 4281306802 4289578443 4294111729 4288980641 16777215 16777215 4288980641 4294769916 4293783021 4292337107 4281306802 4289254892 4286823898 4286823898 4290567150 4281306802 4289446856 4293783021 4294506744 4288980641 16777215 16777215 4288980641 4294243572 4294769916 4293783021 4292337107 4281306802 4290567664 4289254892 4281635253 4289446856 4293783021 4294769916 4294243572 4288980641 16777215 16777215 4288980641 4293783021 4294243572 4294769916 4294769916 4292732122 4282422196 4281306802 4289907150 4294769916 4294835709 4294243572 4293783021 4288980641 16777215 16777215 4288980641 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294506744 4294506744 4294111986 4294111986 4293783021 4288980641 16777215 16777215 4288980641 4288980641 4288980641 4288980641 4288980641 4288980641 4288980641 4288980641 4288980641 4288980641 4288980641 4288980641 4288980641 4288980641 16777215 16777215 4288980641 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4288980641 16777215 16777215 4288980641 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4288980641 16777215 16777215 4288980641 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4288980641 16777215 16777215 4288849568 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4288849568 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallSaveNewIcon (in category 'accessing - icons') -----
+ smallSaveNewIcon
+
+ ^ Icons
+ at: #smallSaveNewIcon
+ ifAbsentPut: [ self smallSaveNewIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallSaveNewIconContents (in category 'private - icons') -----
+ smallSaveNewIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 2089200540 2119802550 1865322161 2351730865 3559886514 4281306802 4164849841 3847723431 2238554017 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1581749686 2120857815 1569835238 3451969523 4292602614 4292012277 4289452015 4252872386 4249392559 461679227 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4287999926 4286748316 4284126380 4282227390 4282424771 4289779178 4291749876 4283738575 4284780964 4287862160 4287862160 4287862160 4287862160 4288849568 16777215 16777215 4288587684 4294967295 4293455075 4292404714 4286495186 4281306802 4290436848 4288991207 4284654271 4292930288 4294967295 4294967295 4294967295 4288980641 16777215 16777215 4289047457 4294243572 4294243572 4293586409 4287477965 4281306802 4287218657 4288859618 4282159540 4290892761 4294243572 4294178036 4294178036 4288980641 16777215 16777215 4288980641 4294112243 4281306802 4281306802 4281306802 4281306802 4287218657 4284068825 4281306802 4281306802 4281306802 4281306802 4294177779 4288980641 16777215 16777215 4288980641 4294046193 4292534487 4281306802 4289254892 4286693081 4286693081 4286693081 4286823898 4289188586 4281306802 4289578443 4294111729 4288980641 16777215 16777215 4288980641 4294769916 4293783021 4292337107 4281306802 4289254892 4286823898 4286823898 4290567150 4281306802 4289446856 4293783021 4294506744 4288980641 16777215 16777215 4288980641 4294243572 4294769916 4293783021 4292337107 4281306802 4290567664 4289254892 4281635253 4289446856 4293717228 4294704123 4294177779 4288980641 16777215 16777215 4288980641 4293783021 4294243572 4294769916 4294769916 4292732122 4282422196 4281306802 4289907150 4294769916 4294901502 4285890304 4294638330 4288980641 16777215 16777215 4288980641 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294440951 4294835709 4285890304 4294508288 4285890304 4293190883 16777216 16777215 4288980641 4292598747 4292598747 4292598747 4292598747 4292467161 4292598747 4292598747 4294243572 4285890304 4289311744 4294508288 4289311744 4285890304 3003121663 16777215 4288980641 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4285890304 4294508288 4294508288 4294508288 4294508288 4294508288 4285890304 16777215 4288980641 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4291085252 4293783021 4285890304 4289311744 4294508288 4289311744 4285890304 3003121663 16777215 4288980641 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4293783021 4285890304 4294508288 4285890304 4293190883 16777215 16777215 4288849568 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4287862160 4292796381 4285890304 4292796381 4288849568 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallScreenshotIcon (in category 'accessing - icons') -----
+ smallScreenshotIcon
+
+ ^ Icons
+ at: #smallScreenshotIcon
+ ifAbsentPut: [ self smallScreenshotIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallScreenshotIconContents (in category 'private - icons') -----
+ smallScreenshotIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 1982540587 4283392626 4284446346 4284446346 4284446346 4265561434 1462117926 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4282009685 4294967295 4294967295 4294967295 4294967295 4278190079 4282075478 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4282010199 4292209663 4294967295 4294967295 4294967295 4289649663 4282075478 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281483596 4285105307 4288332514 4288859118 4289649151 4285237151 4282207836 16777215 16777215 16777215 16777215 2738567995 4283524727 4283129455 4282339422 4282471266 4282997611 4287410126 16777215 16777215 16777215 4288595688 4281088066 4282207836 4282339422 4283393141 2738567995 4284315017 4291028223 4290371327 4294967295 4294967295 4289649663 4287871704 4288793068 4289123060 4289583358 4289649151 4291553535 4289649151 4291028223 4291815679 4262992929 4284907927 4289649663 4284578703 4289386490 4289649663 4288595688 4291422207 4292472319 4291815679 4289649663 4288464102 4288464102 4287673812 4285500581 4290633983 4262992929 4284512397 4289452028 4284578703 4285830059 4288661482 4291028223 4290043391 4288661482 4288201184 4288201184 4287805142 4289386490 4285895853 4283524727 4289649663 4262992929 4284248967 4289188854 4284578703 4286093489 4289452028 4288135134 4288595688 4284512397 4281351496 4283656571 4287673812 4286159027 4288398052 4284117381 4289649663 4262992929 4284248967 4289188854 4284578703 4286093489 4288595688 4285500581 4281614926 4280429620 4279440147 4279440147 4281483596 4285105307 4285500581 4285171101 4289452028 4262992929 4284248967 4289188854 4284578703 4286685886 4285632423 4282997611 4282405472 4294967295 4289649663 4283393141 4281219910 4284973977 4285171101 4286356407 4289452028 4262795547 4284248967 4289188854 4284578703 4287476176 4285171101 4281746770 4283393141 4289649663 4294047999 4291422207 4284248967 4286159027 4285237151 4285830059 4289386490 4262795547 4284248967 4289188854 4284644497 4286685372 4285171101 4283063661 4279440147 4285961903 4292997631 4292866559 4286817728 4287673812 4285237151 4285961903 4288661482 4262269971 4283854207 4287937498 4288332771 4288003291 4288332514 4284842133 4280693050 4283524727 4284248967 4287410126 4290239999 4288201184 4288464102 4287015107 4286357176 4198056779 2738567995 4283854207 4283392626 4283392626 4262335254 4285171101 4285434531 4283393141 4284315017 4286093489 4284512397 4284051331 4283524727 4283392626 4283392369 2738567995 16777215 16777215 16777215 16777215 1261844022 2218408506 3578481483 4250166386 4283985793 4250166386 3595324751 1849178168 858927666 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallSearchIcon (in category 'accessing - icons') -----
+ smallSearchIcon
+
+ ^ Icons
+ at: #smallSearchIcon
+ ifAbsentPut: [ self smallSearchIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallSearchIconContents (in category 'private - icons') -----
+ smallSearchIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 2844298120 4118971263 4270032000 4286677886 4102062717 2542571658 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1049398408 4169171584 4275361492 4292993763 4275887841 4292468193 4292796385 4275360979 4152328574 982356365 16777215 16777215 16777215 16777215 16777215 898667920 4269966464 4292993762 4188256462 4051150803 4202607067 4286296026 4050822352 4188584911 4293190884 4253123454 832018322 16777215 16777215 16777215 16777215 4118774141 4292993505 4204180946 4269518811 3989823728 3957780472 4242861558 3736589034 4252741594 4187666386 4293059298 4085153916 16777215 16777215 16777215 1989120396 4206278581 4188782032 4269518810 3890014453 3958108664 4042257914 4243058680 3705071349 3265316323 4269453018 4189701845 4155683760 1871811470 16777215 16777215 4286348921 4292993504 4285571534 4189508073 4225821173 4226149879 4209504247 4293258742 4040549618 3616191967 3850022619 4287476438 4292927711 4286348921 16777215 16777215 4269900670 4292862434 4286230234 3418150637 3453149937 3336103923 3235703028 3856394484 1854058716 2054926555 2340269274 4286230234 4293454056 4269900670 16777215 16777215 4202725756 4293256677 4269846745 3013262819 3049314029 2999902193 2580077294 2762853096 1517990106 1820176348 2189209564 4235700950 4293059298 4185883004 16777215 16777215 3348469650 4224700367 4237407702 3312690387 2340269274 1970974426 1585098972 1920839387 1333702363 1702801116 3211500488 4254447831 4174631890 3231094675 16777215 16777215 1654103191 3801388691 4292403431 4286296026 2558111192 2004528861 1652207325 2172366553 1434169051 2071374035 4286296026 4292468967 3933895800 2122877572 16777215 16777215 16777215 3883761531 3971463351 4291024100 4286296026 3496384451 1987685334 2742594518 3445920446 4286361562 4291811035 4272203427 4120418711 4068179065 426141286 16777215 16777215 781949846 4152328572 3819086754 4292995310 4288790749 4269977817 4286296026 4288856541 4292666346 4252860027 4291151300 4288125334 4253518213 3917052791 813727872 16777215 16777215 781949846 3833430139 3700527759 3802177952 4073573837 4293256677 3634076827 3782703477 1668247407 4286611838 4291085506 4288322970 4258386385 4286546045 16777215 16777215 16777215 16777215 1637391254 3063520407 4118774140 4286546300 3063520407 1637391254 16777215 2256436862 4286546045 4292203988 4292796126 4286546045 16777215 16777215 16777215 16777215 33554432 67108864 83886080 100663296 100663296 117440512 100663296 100663296 1685419381 4269834365 4286546045 1451262077 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallSelectIcon (in category 'private - icons') -----
+ smallSelectIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallSelect'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSelectIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallSelectIconContents (in category 'private - icons') -----
+ smallSelectIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallSelect.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABK0lEQVR4nKXOO0oEQRAG4L+6q2cfjojgBmJi
+ YmroEQwNBBPxFF7AzBt4DMHcyFwUE2MRPIDruuxMd9VvsKCbrOJOQVNNPT5KcHK7gTjdA2UH
+ MQzgnoCQIJ6AEAE3QFqQBSFk0DMcBaot1uxOobPjm/ODy/WhxrqvWvei1r35v1+FUIzM5mwz
+ PZt7a2Qx98eX9/Hp1cOFJpV0uD8aYUmkKJJixLBCXKxv1qmCSz/0VKtly79FEJlnjdBVgG+o
+ CljpgoVLJP499guQVFInIDtKJ6DJ3nQCPps86wTkgoYAVwYAycXYARAW8/8DKQZBgCgczdPr
+ x3h3azBwEtmc5qQZWZx0gsXJUpzFOe85+fw2mQCIgrPrbVg6AtFAQgHpAOznyTzTHRCDLNRt
+ ev8FfDedurn+q90AAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>smallSqueakIcon (in category 'private - icons') -----
+ smallSqueakIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallSqueak'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSqueakIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallSqueakIconContents (in category 'private - icons') -----
+ smallSqueakIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallSqueak.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACWklEQVQ4jcWSW0hTARzGv52zeXY25ub0eEFd
+ BBsztbYcC8PWhZEsctm6jFlEWkQRBT4U0ioiirSHMAgzijDqLeqlop60jGhGiEoaydKtXXWX
+ pmdubpN5eukhTKM3v8f/x//38v2A1Q75j05UpVNfy5NLbdFwzANgCgCZV5h3qLiMaZ2JsjSA
+ sZUA5Jb62uFae3Mju1FZM+cLH6eynENdvfbe4dPWMw1NJj3KGWPSG6KXBejqNHeNF47uejo1
+ zWP7R5AqZ0hJcr7x7PlmlUgioi6fuA6/qpQWpRfy+csBKtUbjoiHEqj7HoCsQIVMGYEhZ0Cq
+ 3WNAgUCAm/YupL66QcokxQQAHgkcLAH/EgAZAFRVa4TvevvQcqAJ2dgcnHMp7LfVo292Ft1+
+ PwiSACWikQzFUoQExK1OMHceg7m6GULHTsv2jkg0QnBiGi6XC8FgEJkgiwabCYowi8EbT+Af
+ /wG5VsnFIzND/CoI1+8DU7QIHixEVilpaWwrUinw6dE0KIqCx+MBXVOCjJdEca4YW5UK8E9a
+ 4B33JOIT/nYiBzn5I+AjCAoDQoLU1WkgpQRob7XhQ+Ab1pmNsO7ehp+RBE7Z7CHn6EQ0PDYZ
+ i/YPdwIY4FMQHOuAp4uleSrVOaucTWfIZDyB9HwabRetWOA4OD5OYtTnRTKZvvK858XD3/6k
+ AID3pziMVvlerKuoUGyqFNDy3Jzc0kL0vv3M7fAtcu5w8OXgs9d7ly7GW3owm82v9Hq9UV6Q
+ H7/dc/+Ly+3uzoZn3wBIrCDd3xYaDAa7yWR6AGDN/z6tXn4B2ljYZPClNw8AAAAASUVORK5C
+ YII='!
Item was added:
+ ----- Method: MenuIcons class>>smallTimerIcon (in category 'accessing - icons') -----
+ smallTimerIcon
+
+ ^ Icons
+ at: #smallTimerIcon
+ ifAbsentPut: [ self smallTimerIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallTimerIconContents (in category 'private - icons') -----
+ smallTimerIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 4288526525 4116212343 4116212343 4288526525 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4284515726 4284515726 4284515726 4284515726 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4284515726 4284515726 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2639020888 4116212343 4284449675 4284515726 4284909712 3377418592 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1414084431 4149767289 4288526525 4291550689 4292208362 4292274155 4291419360 4288525497 4284515981 1414084431 16777215 16777215 16777215 16777215 16777215 1414084431 4267474568 4291090909 4291286488 4291875796 4284534498 4284534498 4293322728 4291877082 4291090909 4284450703 1414084431 16777215 16777215 16777215 16777215 4099434870 4291090909 4290693837 4292798956 4284534498 4284534498 4284534498 4294046451 4293849072 4290693837 4291090909 4099434870 16777215 16777215 16777215 2639020888 4288526525 4291089366 4292730334 4278190080 4284534498 4284534498 4284534498 4294178037 4293914865 4292730334 4291089366 4288526525 2639020888 16777215 16777215 3931463791 4291550689 4290561222 4294046451 4293522164 4278190080 4285054413 4284534498 4294178037 4293980401 4294046451 4290561222 4291550689 4285369491 75530240 16777215 4284450446 4292208362 4291415245 4293980401 4294243573 4294310137 4278190080 4280778896 4293190885 4293914865 4293914608 4294440951 4292076519 4284582032 16777215 16777215 3931463791 4291550689 4290363586 4294243573 4293717229 4293783279 4284966759 4278190080 4293651693 4293454314 4294506745 4294046194 4291550689 4284842635 16777215 16777215 2639020888 4288526525 4290497486 4293651436 4294046193 4293717229 4294506745 4293585900 4293454057 4294111987 4294506744 4292272611 4288526525 4066077045 16777215 16777215 16777215 4116146551 4291090909 4289838785 4293980401 4294309365 4293717229 4293191142 4293783279 4294309366 4293323499 4291090909 4284712333 890442520 16777215 16777215 16777215 1731932739 4284251783 4291090909 4290562765 4291678674 4294309366 4294177780 4294375159 4292600805 4291090909 4284581518 3493280325 1325400064 67108864 16777215 16777215 385875968 2385323570 4216680057 4288526525 4291550689 4292208362 4292274155 4291550689 4288526525 4284514697 3593219383 2147483648 1090519040 16777215 16777215 16777215 16777215 520093696 1509949440 3493476934 4233325429 4284383883 4284450703 4284185988 4064366169 2650800128 2097152000 939524096 33554432 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallTrafficIcon (in category 'accessing - icons') -----
+ smallTrafficIcon
+
+ ^ Icons
+ at: #smallTrafficIcon
+ ifAbsentPut: [ self smallTrafficIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallTrafficIconContents (in category 'private - icons') -----
+ smallTrafficIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 422804152 4281694648 4281694648 4281694648 4281694648 4281694648 4281694648 422804152 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4289448421 4292255918 4293546071 4293546071 4292255918 4289448421 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4293546071 4294836738 4294836738 4293546071 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4293546071 4294836738 4294836738 4293546071 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4292255918 4293546071 4293546071 4292255918 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4292265390 4293569111 4293569111 4292265390 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4293569111 4294872578 4294872578 4293569111 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4293569111 4294872578 4294872578 4293569111 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4292265390 4293569111 4293569111 4292265390 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4287747246 4282960727 4282960727 4287747246 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4282960727 4278370818 4278370818 4282960727 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4291288047 4282960727 4278370818 4278370818 4282960727 4291288047 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4281694648 4289448421 4287747246 4282960727 4282960727 4287747246 4289448421 4281694648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 808811194 4281694648 4281694648 4281694648 4281694648 4281694648 4281694648 808811194 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallUndoIcon (in category 'accessing - icons') -----
+ smallUndoIcon
+
+ ^ Icons
+ at: #smallUndoIcon
+ ifAbsentPut: [ self smallUndoIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallUndoIconContents (in category 'private - icons') -----
+ smallUndoIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 4292129024 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 348959488 4292129024 4292129024 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 295077632 4292129024 4294834103 4292129024 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 295077632 4292129024 4294834103 4294962176 4292129024 4292129024 3889082880 3486232576 2764878080 193694464 16777215 16777215 16777215 16777215 16777215 295077632 4292129024 4294834103 4294633738 4294896384 4294832763 4294832503 4294635126 4177194867 3570184704 3587224576 479367680 16777215 16777215 16777215 177838336 4292129024 4294834103 4294633472 4294699535 4294370304 4294633472 4294370304 4293646336 4294107683 4294635120 4276869437 3838882816 848269056 16777215 16777215 4292129024 4294834103 4294633472 4294765071 4294699535 4294699535 4294633472 4294370304 4293909760 4293909760 4293909760 4294107683 4293515323 3402478080 177838336 16777215 295077632 4292129024 4294832770 4294765071 4294567680 4292988160 4292988160 4292988160 4293909760 4293909760 4293909760 4293448704 4294438002 4174625536 3419123968 16777215 16777215 295077632 4292129024 4294832766 4293185536 4294832766 4294766704 4294766704 4294766704 4294766704 4294764032 4293448704 4293054208 4294042744 4107187200 16777215 16777215 16777215 295077632 4292129024 4294832766 4294832766 4292129024 4292129024 4292129024 4292129024 4292000000 4294175095 4293448960 4294372208 4174361600 16777215 16777215 16777215 16777215 295077632 4292129024 4294832766 4292129024 16777215 16777215 819310336 1355393280 3386159616 4294569333 4294240640 4291867648 16777215 16777215 16777215 16777215 16777215 16777215 4292129024 4292129024 16777215 16777215 16777215 16777215 449753344 4292262912 4277595539 4291932928 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4292129024 16777215 16777215 16777215 16777215 16777215 4275681792 4277134179 4023367168 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 584233984 4242919490 4276277570 2144319232 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1574154752 3002197102 2933044736 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1775351296 1775482368 416658688 16777215 16777215)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>smallUpdateIcon (in category 'private - icons') -----
+ smallUpdateIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallUpdate'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallUpdateIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallUpdateIconContents (in category 'private - icons') -----
+ smallUpdateIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallUpdate.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACz0lEQVR4nI3SW2hTBwDG8f85iSdpEnIxR+01
+ 0TlmbawOWy8PdXZYFRXLVHwYLt5ARMUXH0Rh0DxIq1jQl3irw6KCSMecKDiYVZEZ6+jEFsrs
+ apektsY2tWnNSU/S0+T45IMgxO/5+35Pn8CXRyqysRmROoOIVReJSDl+MeZbOcx85XaYL2/Z
+ tnV1bd16saKyGovVgZJ8z/ZNNQvzAYt27tja/dOe3UJfLEXwfhjloQqiAX+1i5JS75J8gDh/
+ /jzhbqifJxNejHIFVWUzmcxo9IR7sNrs5nzAlDqp6mFVEYQCAZ9nJovnyuR0nbe9r3n+Ovom
+ HzCazkzp5aUOwW1zM8tupvvvByhDL1lTs5Shwcg1sbzUsq92xcK++rqVI99VL+gvdnLLbWHZ
+ R6C9/VFkTbWXRF+IcPtF0rF/WVtTyc0r5yfC72gRdmypGzjbcrPsRU8vnuLZSKLGrbartN24
+ 8bb/VeRoMsd/P9av+8vhchlNZhMDkQGms9ncLM/immAw+FS0O53uI40XOPnnMAdau/Cf/oNh
+ oZizF84VHjy0r1VVGej8p6szq88gqYgsqKhiND7aVVRUdALAKCLqU7qRVb5isjmdjl4DnUkd
+ 57OX2O02Ach0vxpe2xe97isw4RlTuAcotRtzjwHEWGww7il0kZvWMBkNfF3oACClTDIxkcwC
+ aUBRNZ6NKbQBSiAQcEqSpAIYX3SGWv0HjwXu3G7BOnseGYsXr7uQ5XPLaAn+PgJMAjQ1NS0T
+ BEFOp9OqLMtHotHoJQABkDasXvLcv3evr6M7yrSWwfNNJb45Art37W86fDTwsyzLv42Pj49o
+ mpaSJMmUSCTuNTc33/kIUAUW/6njqY5QCKvNSmwwRkpNx1d+X7+npKTkQCKRaG9oaDjzuaMY
+ AGKgxYf+r9hU/0O5JBWIY2PvctGheOjbquWueDz+a2NjY2uew30SJ2D70vIHGPAd/9jj14AA
+ AAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>smallVolumeIcon (in category 'private - icons') -----
+ smallVolumeIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'smallVolume'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallVolumeIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>smallVolumeIconContents (in category 'private - icons') -----
+ smallVolumeIconContents
+ "Private - Method generated with the content of the file /home/dgd/smallVolume.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAQAAAC1+jfqAAAAAmJLR0QA/4ePzL8AAAE3SURB
+ VHjajdE/SJRxHMfxF/f8Hp/n7vLhlAKhyKRCOpccA6EbFEW0BsciyKWphiBoCRuiQXEJnIyG
+ ampyEppydy8wBOFEyPzHA0X1wNGggV0Ivbbv8h3eH44rKWkT/XUNqdhxgrjz5kBTA90SiVlD
+ h0+PdI6PvZhKwDmPVL13G4KaOqcuTL+6k3z8iis+Sd0175pxy0H91ss066g+SKo+Q68uq4Zd
+ 9M5DyyUdE6dHzg7XIrmdM7XHPriq8NoNaxJdgRypA7/Ezo8e9NjDpgzfhMC+kp92FXZb++u+
+ KKPbd5S1Ak2xVJ+WH3nzqQE5Jq3IpPJgY2GOrDe+NxhCYUvZkkGXvHHfkuJPhkr/4pNiZlsD
+ dbPq+ryVHS9Zqc1c39JAJhF5Zqw9dsXzw7yIXBb/u0fUNt7/+A0ZzEdfNHX2/wAAAABJRU5E
+ rkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>smallWindowIcon (in category 'accessing - icons') -----
+ smallWindowIcon
+
+ ^ Icons
+ at: #smallWindowIcon
+ ifAbsentPut: [ self smallWindowIconContents ]!
Item was added:
+ ----- Method: MenuIcons class>>smallWindowIconContents (in category 'private - icons') -----
+ smallWindowIconContents
+ ^ (Form
+ extent: 16 at 16
+ depth: 32
+ fromArray: #( 1556466370 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 1556466370 16777215 16777215 16777215 16777215 4291217859 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4291217859 16777215 16777215 16777215 16777215 4291217859 4294901502 4279720860 4279720860 4279720860 4279720860 4279720860 4279720860 4279720860 4279720860 4294835709 4291217859 16777215 16777215 16777215 16777215 4291217859 4294835708 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4294769916 4291217859 16777215 16777215 16777215 16777215 4291217859 4294704379 4294638330 4294638330 4293388774 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 1556466370 4291217859 4294572537 4294506744 4294441208 4291217859 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4291217859 4291217859 4294572537 4294374901 4294309365 4291217859 4294901502 4279720860 4279720860 4279720860 4279720860 4279720860 4279720860 4279720860 4279720860 4294835709 4291217859 4291217859 4294309365 4294046193 4294111986 4291217859 4294835708 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4281563063 4294769916 4291217859 4291217859 4294111987 4293914350 4293848814 4291217859 4294704379 4294638330 4294638330 4294638330 4294572793 4294572537 4294572537 4294572537 4294572537 4294572793 4291217859 4291217859 4294046449 4293585643 4293585642 4291217859 4294572537 4294506744 4294441208 4294506488 4294506744 4294506487 4294440951 4294506487 4294506487 4294572537 4291217859 4291217859 4294374901 4294112242 4294177522 4291217859 4294572537 4294374901 4294309365 4294309365 4294309365 4294243829 4294309365 4294309365 4294374901 4294506744 4291217859 1589888702 4291217859 4291217859 4291217859 4291217859 4294309365 4294046193 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294046193 4294243828 4291217859 16777215 16777215 16777215 16777215 4291217859 4294111987 4293914350 4293848814 4293848814 4293848814 4293783021 4293848814 4293848557 4293848558 4294111986 4291217859 16777215 16777215 16777215 16777215 4291217859 4294046449 4293585643 4293585642 4293585898 4293585642 4293585642 4293585642 4293585642 4293585642 4294046193 4291217859 16777215 16777215 16777215 16777215 4291217859 4294374901 4294112242 4294177522 4294111986 4294112243 4294111986 4294111986 4294177522 4294111986 4294111986 4291217859 16777215 16777215 16777215 16777215 1589888702 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 4291217859 1556466370)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: MenuIcons class>>squeakIcon (in category 'private - icons') -----
+ squeakIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'squeak'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self squeakIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>squeakIconContents (in category 'private - icons') -----
+ squeakIconContents
+ "Private - Method generated with the content of the file /home/dgd/squeak.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAFoklEQVRIie2VbXBU1RnHf/fu3ddsNrtsdmGT
+ QN5gk2wQsiFWYpMgWE2DLaVqU5sPpEVq0VZn0k+ttaVjKwQcmLF+YIoNji/pkKYyrYQWMYIE
+ quhEA+ElWRuTkLqbCNld9m6yy97N3tsPDLbTzmjkmzP+Pp455/mdeeb/nANf8kVHdxNnbi2v
+ 8m63Zmc9Il+NuzVNOw8o/7On0Ol2/MjpdjwxIyeqNE2TgBEA4XOIxPzi/D/mL1l0R8PGNQs/
+ SCY5deBoZiZ0ZU6vZDbOyrNHAJ07z9UxI89+984NDXqHy6ELjoVi7554X0kkEl2ZdObReQuL
+ vIWvtDx8/73OTY08NzlJQlVBVYl1HEY9cHwmfiW6wrbA+pi/duVD7fu3WRa4F5CYTRJJp9l3
+ LkBv8xPx8FS4QZyn7xs+f1n94u838btgkISqkgnLpAZHydl8D6am1VlZDtvBHId9y479v7bo
+ DXqe/MkuGvKb+GbxtzgeGGVpa5MEbJTmYytctuTx5f7lrt1Pv0RuaR4fPvUCXFNQVZVYOoNx
+ w+1Cvn/ZigdbN4hOtwMlpZDJZIjHZgDQHRtg5jtrzSazoXE+PrF+Xd1MMBjUuru7Nbe/TNu9
+ Z4+2d+9erezer2kvv7VfW1JeqBX6SrTD57u0d9OntYDWr51Jva25PLkaoJlqyrWC489ouR7X
+ h/Npqanav8rQ399PIBBg0/r7+GlbG5s3b6alqp6uaJTOY7/HbsuipKKYE7EYAAevRslxZANg
+ yDajxhMg6eZuCPXAVhH+IMFOoPa/hKniolKpo6ODrq4uVvurOXnyJBUVFaSupXjtyD+wL3Li
+ XV6KKIq8Mj3NoXCYU1emCV6aul7cmYM6Febq5ciIBGTr4LXbMXs2YS2IoQrPEtsqoz4VRd0F
+ iJejV9R0Oq2zWq3U1dXR3t6O3W5ncHAQpwOCqRS/2fcLAJySxJFIBOG5wyRnkwBYbvORGRhJ
+ zqWUPhH4+XqyrG/gKWolW3qMHN2b5NtsiI97K0t6Vn6l8lJgeFhsbm7GarViNBqZmJigpaUF
+ t9uNUW8gMDBKPHo9IHUnL9Jf+zBvPNMFQG6eC92aKuS/nY4CJ3QCbPsLC312JEMCCQGwIzAp
+ qMaC1ru8e/7Unu2vrxRePXKakekpli7MI5lM0tnZiaqqDCw282BJDaF/higoX0RFVRlKSuGd
+ 4/1Ysi1Ubt+KcnEsM3Wwbwh4UhIRDDI24wXMaDdSQgazIAvuskIAFrgd/HDbfXjluxjsvEBr
+ ayuBQIBFHg9n1now63TYbIv52cuHeGBpMT/+5RZubfBz4FqCM+NBIu2dMU3TfgVoUinmcDey
+ 9ADmT1Iyi8jf9Wna71hFcDz0yfpah40ui8zY+DhtbW207N/NQ6ub+Pj1ECWLl3G055R2bvCF
+ i5U1Pl9BUZ4gjwX5uLs3PZdK7wJeB5DuxrntVcJ3p0FqIAeZDM8ziX9dDUtKC1BVlVQyRTw2
+ y/RUmB+0fp3u/vP0BMb43vYtbHK5mMgXGZ4YRRwNXRsZGq8vLC+6rfevJx6dvDQpz6XSHUDv
+ jUsLAN8m1ztEYk8KbUXcIlotDSvtu/+8Q7jFYiEWkVFSCiazEVOWBZ1ORKf7z/j2HX2PcouP
+ nvdP8/yLHQOX3xuu/rSh/v/Hu9i9UK+J54R11bkNj9wvrDMYKTeZyJH0uDy5GE0GkqrKcCJB
+ XyyG8dhHrPEs5bdP7wj3H33TA6Q/n/A6ea4Sz7OynLgn685V6my116i/pVjMynOhZDLIsVky
+ Z0fIfntIq01b1JH45UOjve80f5bs04QA1NTU9NbW1n41FAqlLv1rQhQknRqORMSP5EhAyahv
+ EZ3pQ1F6gNRnieaL3efzXdi5c2fi7NmzmizLWmNj4weA/WYLzusD9nq9651O51ZFUYShoaF9
+ iUTi0M0Kv+SLz78BjzNWmYcZV74AAAAASUVORK5CYII='!
Item was added:
+ ----- Method: MenuIcons class>>squeakLogoIcon (in category 'accessing - icons') -----
+ squeakLogoIcon
+ ^ Icons
+ at: #squeakLogoIcon ifAbsentPut: [(Form
+ extent: 24 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 67108864 2063597568 1778384896 889192448 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1610612736 1811939328 1610612736 16777215 16777215 16777215 16777215 16777215 905969664 889192448 16777215 1442840576 788529152 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1711276032 469762048 16777215 1728053248 16777215 16777215 16777215 16777215 16777215 1006632960 704643072 16777215 16777215 1895825408 234881024 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 838860800 16777215 16777215 1728053248 16777215 16777215 16777215 16777215 16777215 738197504 989855744 16777215 16777215 167772160 1862270976 16777215 16777215 16777215 16777215 16777215 16777215 16777215 83886080 1879048192 16777215 16777215 16777215 1744830464 16777215 16777215 16777215 16777215 16777215 469762048 1258291200 16777215 16777215 16777215 1543503872 520093696 16777215 16777215 16777215 16777215 16777215 16777215 1543503872 335544320 16777215 16777215 16777215 1761607680 16777215 16777215 16777215 16777215 16777215 16777216 1644167168 16777215 16777215 16777215 33554432 67108864 16777215 16777215 16777215 16777215 16777215 16777215 33554432 16777215 16777215 16777215 16777215 1795162112 16777215 16777215 16777215 16777215 16777215 16777215 1711276032 16777215 16777215 16777215 16777215 16777215 117440512 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 100663296 1677721600 16777215 16777215 16777215 16777215 16777215 16777215 1744830464 16777215 16777215 16777215 16777215 3019898880 4009754624 1056964608 16777215 16777215 1090519040 3204448256 1325400064 16777215 16777215 16777215 889192448 889192448 16777215 16777215 16777215 16777215 16777215 16777215 1392508928 352321536 16777215 16777215 637534208 4278190080 4278190080 2650800128 16777215 16777215 3372220416 4278190080 3758096384 16777215 16777215 16777215 1560281088 117440512 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 134217728 4060086272 4278190080 1929379840 16777215 16777215 3187671040 4278190080 3590324224 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 704643072 1577058304 83886080 16777215 16777215 771751936 2667577344 956301312 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 369098752 973078528 1577058304 1728053248 1711276032 1325400064 805306368 218103808 16777215 858262026 925501705 16777216 16777215 268435456 788529152 1308622848 1593835520 1056964608 436207616 16777216 16777215 16777215 1442840576 1761607680 1409286144 788529152 301989888 872415232 1124073472 1627389952 1929379840 973078528 2032667403 4280814347 4280814347 2166885388 1040187392 1946157056 1577058304 939524096 452984832 687865856 1325400064 1778384896 1795162112 1392508928 16777215 16777215 855638016 1795162112 1677721600 855638016 620756992 436207616 486539264 285212672 2032667403 4280814347 4280814347 2166885388 486539264 1023410176 922746880 1157627904 1392508928 1845493760 1744830464 486539264 16777215 16777215 201326592 2013265920 1006632960 16777215 553648128 1694498816 1778384896 1694498816 1728053248 738197504 16777215 858262026 925501705 16777216 738197504 1728053248 1744830464 1778384896 1476395008 251658240 117440512 1476395008 1879048192 150994944 16777215 16777216 16777215 486539264 1426063360 16777216 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 234881024 1728053248 486539264 16777215 167772160 50331648)
+ offset: 0 at 0)]!
Item was added:
+ ----- Method: MenuIcons class>>squeakLogoInvertedIcon (in category 'accessing - icons') -----
+ squeakLogoInvertedIcon
+ ^ Icons
+ at: #squeakLogoInvertedIcon ifAbsentPut: [(Form
+ extent: 24 at 16
+ depth: 32
+ fromArray: #( 16777215 16777215 83886079 2080374783 1795162111 905969663 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1627389951 1828716543 1627389951 16777215 16777215 16777215 16777215 16777215 922746879 905969663 16777215 1459617791 805306367 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1728053247 486539263 16777215 1744830463 16777215 16777215 16777215 16777215 16777215 1023410175 721420287 16777215 16777215 1912602623 251658239 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1224736767 855638015 16777215 16777215 1744830463 16777215 16777215 16777215 16777215 16777215 754974719 1006632959 16777215 16777215 184549375 1879048191 16777215 16777215 16777215 16777215 16777215 16777215 16777215 100663295 1895825407 16777215 16777215 16777215 1761607679 16777215 16777215 16777215 16777215 16777215 486539263 1275068415 16777215 16777215 16777215 1560281087 536870911 16777215 16777215 16777215 16777215 16777215 16777215 1560281087 352321535 16777215 16777215 16777215 1778384895 16777215 16777215 16777215 16777215 16777215 33554431 1660944383 16777215 16777215 16777215 50331647 83886079 16777215 16777215 16777215 16777215 16777215 16777215 50331647 16777215 16777215 16777215 16777215 1811939327 16777215 16777215 16777215 16777215 16777215 16777215 1728053247 16777215 16777215 16777215 16777215 16777215 134217727 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 117440511 1694498815 16777215 16777215 16777215 16777215 16777215 16777215 1761607679 16777215 16777215 16777215 16777215 3036676095 4026531839 1073741823 16777215 16777215 1107296255 3221225471 1342177279 16777215 16777215 16777215 905969663 905969663 16777215 16777215 16777215 16777215 16777215 16777215 1409286143 369098751 16777215 16777215 654311423 4294967295 4294967295 2667577343 16777215 16777215 3388997631 4294967295 3774873599 16777215 16777215 16777215 1577058303 134217727 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 150994943 4076863487 4294967295 1946157055 16777215 16777215 3204448255 4294967295 3607101439 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 721420287 1593835519 100663295 16777215 16777215 788529151 2684354559 973078527 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 385875967 989855743 1593835519 1744830463 1728053247 1342177279 822083583 234881023 16777215 869791221 936769270 33554431 16777215 285212671 805306367 1325400063 1610612735 1073741823 452984831 33554431 16777215 16777215 1459617791 1778384895 1426063359 805306367 318767103 889192447 1140850687 1644167167 1946157055 989855743 2044196084 4292343028 4292343028 2178413555 1056964607 1962934271 1593835519 956301311 469762047 704643071 1342177279 1795162111 1811939327 1409286143 16777215 16777215 872415231 1811939327 1694498815 872415231 637534207 452984831 503316479 301989887 2044196084 4292343028 4292343028 2178413555 503316479 1040187391 939524095 1174405119 1409286143 1862270975 1761607679 503316479 16777215 16777215 218103807 2030043135 1023410175 16777215 570425343 1711276031 1795162111 1711276031 1744830463 754974719 16777215 869791221 936769270 33554431 754974719 1744830463 1761607679 1795162111 1493172223 268435455 134217727 1493172223 1895825407 167772159 16777215 33554431 16777215 503316479 1442840575 33554431 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 251658239 1744830463 503316479 16777215 184549375 67108863)
+ offset: 0 at 0)]!
Item was added:
+ ----- Method: MenuIcons class>>startUp: (in category 'class initialization') -----
+ startUp: resuming
+ resuming
+ ifFalse: [^ self].
+ self initializeTranslations!
Item was added:
+ ----- Method: MenuIcons class>>volumeIcon (in category 'private - icons') -----
+ volumeIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'volume'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self volumeIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>volumeIconContents (in category 'private - icons') -----
+ volumeIconContents
+ "Private - Method generated with the content of the file /home/dgd/volume.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAQAAABKfvVzAAAABGdBTUEAALGOfPtRkwAAACBj
+ SFJNAAB6JQAAgIMAAPn/AACA6QAAdTAAAOpgAAA6mAAAF2+SX8VGAAAAAmJLR0QA/4ePzL8A
+ AAAJcEhZcwAACxMAAAsTAQCanBgAAAHrSURBVDjLldTLahRBFMbx/xu02hEvm1mZIC4qovaA
+ LhoE142+QIMvILoRgjASdKEilSBxO5CFIhKbmUAQNWmD6KCQxCAMEi+JGGKISuETfC665uIM
+ DqRqd6hfn9Nd5zRidxsBV/jOH5rc5QhjJBDwnyUQ43xmix9ssMo8GRiygaBBg0dMM887FsCE
+ jvyfUwEZaRdY5CrDnOUyt8GE7pbaIKEEgEGYNnjpowmYIXdfeQfErJMAUCliArFMAJwEM+Sm
+ 9V5r6iopIC+eXdDiK1lycux+90Qb2tavAlQxFxgBwwoAl8haIH+sTKN6oZ/6rW1ttjJYzEMO
+ QZUEKPnTgnxHmzqjHW3pm77ooxApEFC9QwoxVV+U8eCTmirrq9bU1KqWVNZBEewDe55JwGfM
+ iT1Y0hud0gct661ea1HndEzEQOUiUxzoBwt6quNq6JVyPdOcTuuwCE6AtUywpx/Mqq5RPdec
+ ZlVTTTjSBxBgp7gGCRYA136HG7qpYU2qrppqqou8VtxAcI8RyDBACddzD6GzbTAOFYIxjkLs
+ C6pQbYHWMqGbUF11kcNeH2OdEhDgiHsBmNBZzXRaI2XFN4YtWr4LREREYEJ3vQNKfpRSXNGh
+ PaBMBIb+ebA+Tz/wZPDE0ZMjgiAaBHb919jd/gvLk2YJrn7DBgAAAABJRU5ErkJggg=='!
Item was added:
+ ----- Method: MenuIcons class>>windowIcon (in category 'private - icons') -----
+ windowIcon
+ "Private - Generated method"
+ ^ Icons
+ at: #'window'
+ ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self windowIconContents readStream) ].!
Item was added:
+ ----- Method: MenuIcons class>>windowIconContents (in category 'private - icons') -----
+ windowIconContents
+ "Private - Method generated with the content of the file /home/dgd/window.png"
+ ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
+ RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB5UlEQVR4nO2WP2gTURzHP/fuEqMpZ1vUKBqq
+ FHFTB/+0XVSKRSxCBUVHQXHoUHeh4thFVwcnFwWdNFBErWgVVBIXBRGs1pZEjamtucvl7nKX
+ O4fkoPXPkHqCw32m977vz4f3ePB7EBEyUtDoGzrbLRDpMDeX63XjceZqDvCDTAHoP3HuwsHd
+ uy5uVNukuXQXruSR8ORlSaqyS6IuYwqX79MFfKG8mLx9pWeJcNv2HSOnx69Lq18+Z+zRJHmj
+ xNEt+5Al0ZJs3tZ4kM/SrW7ivZant7+Xzx9n9n79NHDkbfbeXcBRAN69eq3cHzzJ+sPHWGsn
+ SMopSvlCy6fz8NmqpOiwYgglxdybaWanpjArCzuBBeCpAmCZVZ4Uiwzs30NXpdRcXm5ZCLAO
+ AJ2U6/Iwl8N1nGCoA5pXGospjI0Oo7YllyX5E4cO9HD8zHlmF2UCYE1nuwhbBhCPx9ic3rAk
+ a+1VhEAkjISR8D8RGlXT9zzvnwjKuvGrsKxXStdujmPZtdBEtZrDrTsTfJgpUDMqepBLAH2D
+ p4aFiF+WJGlFaMYGvmVoz7ITNy4BDpAJvhirVibVoaTaqYZps23L1ue/BHXOATJKs2OahvbN
+ NDQrTOFPFGHRJwqQaRRJ6bfT/w6XRsWPCJ8feQeiSATBXJcAAAAASUVORK5CYII='!
Item was added:
+ StringMorph subclass: #MenuItemMorph
+ instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon lastMousePosition'
+ classVariableNames: 'SubMenuMarker'
+ poolDictionaries: ''
+ category: 'Morphic-Menus'!
+
+ !MenuItemMorph commentStamp: '<historical>' prior: 0!
+ I represent an item in a menu.
+
+ Instance variables:
+ isEnabled <Boolean> True if the menu item can be executed.
+ subMenu <MenuMorph | nil> The submenu to activate automatically when the user mouses over the item.
+ isSelected <Boolean> True if the item is currently selected.
+ target <Object> The target of the associated action.
+ selector <Symbol> The associated action.
+ arguments <Array> The arguments for the associated action.
+ icon <Form | nil> An optional icon form to be displayed to my left.
+
+ If I have a dynamic marker, created by strings like <yes> or <no> in my contents, it will be installed as a submorph.!
Item was added:
+ ----- Method: MenuItemMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "MenuItemMorph initialize"
+
+ | f |
+ f := Form
+ extent: 5 at 9
+ fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648)
+ offset: 0 at 0.
+ SubMenuMarker := ColorForm mappingWhiteToTransparentFrom: f.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>aboutToBeGrabbedBy: (in category 'grabbing') -----
+ aboutToBeGrabbedBy: aHand
+ "Don't allow the receiver to act outside a Menu"
+ | menu box |
+ (owner notNil and:[owner submorphs size = 1]) ifTrue:[
+ "I am a lonely menuitem already; just grab my owner"
+ owner stayUp: true.
+ ^owner aboutToBeGrabbedBy: aHand].
+ box := self bounds.
+ menu := MenuMorph new defaultTarget: nil.
+ menu addMorphFront: self.
+ menu bounds: box.
+ menu stayUp: true.
+ self isSelected: false.
+ ^menu!
Item was added:
+ ----- Method: MenuItemMorph>>action: (in category 'accessing') -----
+ action: aBlock
+
+ self
+ target: aBlock;
+ selector: #value!
Item was added:
+ ----- Method: MenuItemMorph>>activateOwnerMenu: (in category 'events') -----
+ activateOwnerMenu: evt
+ "Activate our owner menu; e.g., pass control to it"
+ owner ifNil:[^false]. "not applicable"
+ (owner fullContainsPoint: evt position) ifFalse:[^false].
+ owner activate: evt.
+ ^true!
Item was added:
+ ----- Method: MenuItemMorph>>activateSubmenu: (in category 'events') -----
+ activateSubmenu: evt
+ "Activate our submenu; e.g., pass control to it"
+ subMenu ifNil:[^false]. "not applicable"
+ (subMenu fullContainsPoint: evt position) ifFalse:[^false].
+ subMenu activate: evt.
+ self removeAlarm: #deselectTimeOut:.
+ ^true!
Item was added:
+ ----- Method: MenuItemMorph>>adaptToWorld: (in category 'accessing') -----
+ adaptToWorld: aWorld
+
+ super adaptToWorld: aWorld.
+ target := target adaptedToWorld: aWorld.!
Item was added:
+ ----- Method: MenuItemMorph>>addSubMenu: (in category 'accessing') -----
+ addSubMenu: aBlock
+
+ subMenu := self createSubmenu.
+ aBlock value: subMenu.
+ self changed.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>addUpdatingSubMenu: (in category 'accessing') -----
+ addUpdatingSubMenu: aBlock
+
+ subMenu := UpdatingMenuMorph new.
+ subMenu updater: aBlock updateSelector: #value:.
+ self changed.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>adjacentTo (in category 'selecting') -----
+ adjacentTo
+
+ ^{ self outerBounds topRight. self bounds topLeft }!
Item was added:
+ ----- Method: MenuItemMorph>>allWordingsNotInSubMenus: (in category 'accessing') -----
+ allWordingsNotInSubMenus: verbotenSubmenuContentsList
+ "Answer a collection of the wordings of all items and subitems, but omit the stay-up item, and also any items in any submenu whose tag is in verbotenSubmenuContentsList"
+
+ self isStayUpItem ifTrue:[^ #()].
+ subMenu ifNotNil:
+ [^ (verbotenSubmenuContentsList includes: self contents asString)
+ ifTrue:
+ [#()]
+ ifFalse:
+ [subMenu allWordingsNotInSubMenus: verbotenSubmenuContentsList]].
+
+ ^ Array with: self contents asString!
Item was added:
+ ----- Method: MenuItemMorph>>arguments (in category 'accessing') -----
+ arguments
+
+ ^ arguments
+ !
Item was added:
+ ----- Method: MenuItemMorph>>arguments: (in category 'accessing') -----
+ arguments: aCollection
+
+ arguments := aCollection.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>bottomArrow (in category 'private') -----
+ bottomArrow
+ ^ ColorForm
+ mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 90) asFormOfDepth:8)!
Item was added:
+ ----- Method: MenuItemMorph>>browseAllImplementorsOfRealSelector (in category 'browse') -----
+ browseAllImplementorsOfRealSelector
+ SystemNavigation default browseAllImplementorsOf: self realSelector localTo: target class!
Item was added:
+ ----- Method: MenuItemMorph>>buildDebugMenu: (in category 'browse') -----
+ buildDebugMenu: aHandMorph
+ | aMenu |
+ aMenu := super buildDebugMenu: aHandMorph.
+ aMenu addLine.
+ aMenu add: 'implementors of' translated target: self action: #browseAllImplementorsOfRealSelector.
+ ^ aMenu!
Item was added:
+ ----- Method: MenuItemMorph>>contentString (in category 'accessing') -----
+ contentString
+ ^self valueOfProperty: #contentString!
Item was added:
+ ----- Method: MenuItemMorph>>contentString: (in category 'accessing') -----
+ contentString: aString
+ aString
+ ifNil: [self removeProperty: #contentString]
+ ifNotNil: [self setProperty: #contentString toValue: aString]!
Item was added:
+ ----- Method: MenuItemMorph>>contents: (in category 'accessing') -----
+ contents: aString
+ ^self contents: aString withMarkers: true!
Item was added:
+ ----- Method: MenuItemMorph>>contents:withMarkers: (in category 'accessing') -----
+ contents: aString withMarkers: aBool
+ ^self contents: aString withMarkers: aBool inverse: false!
Item was added:
+ ----- Method: MenuItemMorph>>contents:withMarkers:inverse: (in category 'accessing') -----
+ contents: aString withMarkers: aBool inverse: inverse
+ "Set the menu item entry. If aBool is true, parse aString for embedded markers."
+
+ | markerIndex marker |
+ self contentString: nil. "get rid of old"
+ aBool ifFalse: [^super contents: aString].
+ self removeAllMorphs. "get rid of old markers if updating"
+ self hasIcon ifTrue: [ self icon: nil ].
+ (aString notEmpty and: [aString first = $<])
+ ifFalse: [^super contents: aString].
+ markerIndex := aString indexOf: $>.
+ markerIndex = 0 ifTrue: [^super contents: aString].
+ marker := (aString copyFrom: 1 to: markerIndex) asLowercase.
+ (#('<on>' '<off>' '<yes>' '<no>') includes: marker)
+ ifFalse: [^super contents: aString].
+ self contentString: aString. "remember actual string"
+ marker := (marker = '<on>' or: [marker = '<yes>']) ~= inverse
+ ifTrue: [self onImage]
+ ifFalse: [self offImage].
+ super contents: (aString copyFrom: markerIndex + 1 to: aString size).
+ "And set the marker"
+ marker := ImageMorph new image: marker.
+ marker position: self left @ (self top + 2).
+ self addMorphFront: marker!
Item was added:
+ ----- Method: MenuItemMorph>>createSubmenu (in category 'private') -----
+ createSubmenu
+
+ ^MenuMorph new!
Item was added:
+ ----- Method: MenuItemMorph>>createUpdatingSubmenu (in category 'private') -----
+ createUpdatingSubmenu
+
+ ^UpdatingMenuMorph new!
Item was added:
+ ----- Method: MenuItemMorph>>defaultBounds (in category 'initialization') -----
+ defaultBounds
+ "answer the default bounds for the receiver"
+ ^ 0 @ 0 extent: 10 @ 10!
Item was added:
+ ----- Method: MenuItemMorph>>deleteIfPopUp: (in category 'initialization') -----
+ deleteIfPopUp: evt
+ "Recurse up for nested pop ups"
+ owner ifNotNil:[owner deleteIfPopUp: evt].!
Item was added:
+ ----- Method: MenuItemMorph>>deselect: (in category 'selecting') -----
+ deselect: evt
+
+ self isSelected: false.
+ lastMousePosition := nil.
+ subMenu ifNotNil: [
+ owner ifNotNil: [ owner activeSubmenu: nil ] ].!
Item was added:
+ ----- Method: MenuItemMorph>>deselectItem (in category 'private') -----
+ deselectItem
+ | item |
+ self isSelected: false.
+ subMenu ifNotNil: [subMenu deleteIfPopUp].
+ (owner isKindOf: MenuMorph) ifTrue:
+ [item := owner popUpOwner.
+ (item isKindOf: MenuItemMorph) ifTrue: [item deselectItem]].
+ !
Item was added:
+ ----- Method: MenuItemMorph>>deselectTimeOut: (in category 'events') -----
+ deselectTimeOut: evt
+ "Deselect timout. Now really deselect"
+ owner selectedItem == self
+ ifTrue:[
+ evt hand newMouseFocus: nil.
+ owner selectItem: nil event: evt].
+ !
Item was added:
+ ----- Method: MenuItemMorph>>doButtonAction (in category 'events') -----
+ doButtonAction
+ "Called programattically, this should trigger the action for which the receiver is programmed"
+
+ self invokeWithEvent: nil!
Item was added:
+ ----- Method: MenuItemMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | stringColor stringBounds |
+ isSelected & isEnabled
+ ifTrue: [
+ aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle.
+ stringColor := color negated ]
+ ifFalse: [ stringColor := color ].
+ stringBounds := bounds.
+ self hasIcon ifTrue: [
+ | iconForm |
+ iconForm := self iconForm.
+ aCanvas
+ translucentImage: iconForm
+ at: stringBounds left @ (self top + (self height - iconForm height // 2)).
+ stringBounds := stringBounds left: stringBounds left + iconForm width + 2 ].
+ self hasMarker ifTrue: [
+ stringBounds := stringBounds left: stringBounds left + self submorphBounds width + 8 ].
+ stringBounds := stringBounds top: stringBounds top + stringBounds bottom - self fontToUse height // 2.
+ aCanvas
+ drawString: contents
+ in: stringBounds
+ font: self fontToUse
+ color: stringColor.
+ self hasSubMenu
+ ifTrue: [| subMenuMarker subMenuMarkerPosition |
+ subMenuMarker := self subMenuMarker.
+ subMenuMarkerPosition := self right - subMenuMarker width @ (self top + self bottom - subMenuMarker height // 2).
+ aCanvas paintImage: subMenuMarker at: subMenuMarkerPosition ]!
Item was added:
+ ----- Method: MenuItemMorph>>duplicateMorph: (in category 'grabbing') -----
+ duplicateMorph: evt
+ "Make and return a duplicate of the receiver's argument"
+ | dup menu |
+ dup := self duplicate isSelected: false.
+ menu := MenuMorph new defaultTarget: nil.
+ menu addMorphFront: dup.
+ menu bounds: self bounds.
+ menu stayUp: true.
+ evt hand grabMorph: menu from: owner. "duplicate was ownerless so use #grabMorph:from: here"
+ ^menu!
Item was added:
+ ----- Method: MenuItemMorph>>hResizing (in category 'layout-properties') -----
+ hResizing
+ "Default to #spaceFill"
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#spaceFill] ifNotNil:[props hResizing].!
Item was added:
+ ----- Method: MenuItemMorph>>handleMouseUp: (in category 'events') -----
+ handleMouseUp: anEvent
+ "The handling of control between menu item requires them to act on mouse up even if not the current focus. This is different from the default behavior which really only wants to handle mouse ups when they got mouse downs before"
+ anEvent wasHandled ifTrue:[^self]. "not interested"
+ anEvent hand releaseMouseFocus: self.
+ anEvent wasHandled: true.
+ anEvent blueButtonChanged
+ ifTrue:[self blueButtonUp: anEvent]
+ ifFalse:[self mouseUp: anEvent].!
Item was added:
+ ----- Method: MenuItemMorph>>handlesMouseDown: (in category 'events') -----
+ handlesMouseDown: evt
+
+ ^ true
+ !
Item was added:
+ ----- Method: MenuItemMorph>>handlesMouseOver: (in category 'events') -----
+ handlesMouseOver: anEvent
+ ^true!
Item was added:
+ ----- Method: MenuItemMorph>>handlesMouseOverDragging: (in category 'events') -----
+ handlesMouseOverDragging: evt
+ ^true!
Item was added:
+ ----- Method: MenuItemMorph>>hasIcon (in category 'accessing') -----
+ hasIcon
+ "Answer whether the receiver has an icon. If menues without icons are
+ requested, pretend to not bear one unless we have not content."
+ ^ self icon notNil and: [
+ Preferences menuWithIcons or: [self contents isEmptyOrNil]].!
Item was added:
+ ----- Method: MenuItemMorph>>hasIconOrMarker (in category 'accessing') -----
+ hasIconOrMarker
+ "Answer whether the receiver has an icon or a marker."
+ ^ self hasIcon or: [ submorphs isEmpty not ]!
Item was added:
+ ----- Method: MenuItemMorph>>hasMarker (in category 'accessing') -----
+ hasMarker
+ "Answer whether the receiver has a marker morph."
+ ^ submorphs isEmpty not!
Item was added:
+ ----- Method: MenuItemMorph>>hasSubMenu (in category 'accessing') -----
+ hasSubMenu
+ "Return true if the receiver has a submenu"
+ ^subMenu notNil!
Item was added:
+ ----- Method: MenuItemMorph>>hasSubMenu: (in category 'accessing') -----
+ hasSubMenu: aMenuMorph
+ subMenu ifNil:[^false].
+ subMenu == aMenuMorph ifTrue:[^true].
+ ^subMenu hasSubMenu: aMenuMorph!
Item was added:
+ ----- Method: MenuItemMorph>>help: (in category 'accessing') -----
+ help: aString
+
+ self setBalloonText: aString!
Item was added:
+ ----- Method: MenuItemMorph>>icon (in category 'accessing') -----
+ icon
+ "answer the receiver's icon"
+ ^ icon!
Item was added:
+ ----- Method: MenuItemMorph>>icon: (in category 'accessing') -----
+ icon: aForm
+ "change the the receiver's icon"
+ icon := aForm.
+ self height: self minHeight.
+ self width: self minWidth!
Item was added:
+ ----- Method: MenuItemMorph>>iconForm (in category 'private') -----
+ iconForm
+ "private - answer the form to be used as the icon"
+ ^ isEnabled
+ ifTrue: [self icon]
+ ifFalse: [self icon asGrayScale]!
Item was added:
+ ----- Method: MenuItemMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+
+ contents := ''.
+ hasFocus := false.
+ isEnabled := true.
+ subMenu := nil.
+ isSelected := false.
+ target := nil.
+ selector := nil.
+ arguments := nil.
+ font := Preferences standardMenuFont.
+ self hResizing: #spaceFill;
+ vResizing: #shrinkWrap!
Item was added:
+ ----- Method: MenuItemMorph>>invokeWithEvent: (in category 'events') -----
+ invokeWithEvent: evt
+ "Perform the action associated with the given menu item."
+
+ | w |
+ self isEnabled ifFalse: [^ self].
+ target class == HandMorph ifTrue: [(self notObsolete) ifFalse: [^ self]].
+ owner ifNotNil:[self isStayUpItem ifFalse:[
+ self flag: #workAround. "The tile system invokes menus straightforwardly so the menu might not be in the world."
+ (w := self world) ifNotNil:[
+ owner deleteIfPopUp: evt.
+ "Repair damage before invoking the action for better feedback"
+ w displayWorldSafely]]].
+ selector ifNil:[^self].
+ Cursor normal showWhile: [ | selArgCount | "show cursor in case item opens a new MVC window"
+ (selArgCount := selector numArgs) = 0
+ ifTrue:
+ [target perform: selector]
+ ifFalse:
+ [selArgCount = arguments size
+ ifTrue: [target perform: selector withArguments: arguments]
+ ifFalse: [target perform: selector withArguments: (arguments copyWith: evt)]]].!
Item was added:
+ ----- Method: MenuItemMorph>>isEnabled (in category 'accessing') -----
+ isEnabled
+
+ ^ isEnabled
+ !
Item was added:
+ ----- Method: MenuItemMorph>>isEnabled: (in category 'accessing') -----
+ isEnabled: aBoolean
+
+ isEnabled = aBoolean ifTrue: [^ self].
+ isEnabled := aBoolean.
+ self color: (aBoolean ifTrue: [Color black] ifFalse: [Color lightGray]).
+ !
Item was added:
+ ----- Method: MenuItemMorph>>isSelected (in category 'selecting') -----
+ isSelected
+ ^ isSelected !
Item was added:
+ ----- Method: MenuItemMorph>>isSelected: (in category 'selecting') -----
+ isSelected: aBoolean
+
+ isSelected := aBoolean.
+ self changed.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>isStayUpItem (in category 'accessing') -----
+ isStayUpItem
+
+ ^selector == #toggleStayUp: or: [selector == #toggleStayUpIgnore:evt:]!
Item was added:
+ ----- Method: MenuItemMorph>>itemWithWording: (in category 'accessing') -----
+ itemWithWording: wording
+ "If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil."
+ (self contents asString sameAs: wording) ifTrue:[^self].
+ subMenu ifNotNil:[^subMenu itemWithWording: wording].
+ ^nil!
Item was added:
+ ----- Method: MenuItemMorph>>leftArrow (in category 'private') -----
+ leftArrow
+ ^ ColorForm
+ mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 180)asFormOfDepth: 8)!
Item was added:
+ ----- Method: MenuItemMorph>>minHeight (in category 'layout') -----
+ minHeight
+ | iconHeight |
+ iconHeight := self hasIcon
+ ifTrue: [self icon height + 2]
+ ifFalse: [0].
+ ^ self fontToUse height + 2 max: iconHeight!
Item was added:
+ ----- Method: MenuItemMorph>>minWidth (in category 'layout') -----
+ minWidth
+
+ | subMenuWidth iconWidth markerWidth |
+ subMenuWidth := self hasSubMenu
+ ifTrue: [ 10 ]
+ ifFalse: [ 0 ].
+ iconWidth := self hasIcon
+ ifTrue: [ self icon width + 2 ]
+ ifFalse: [ 0 ].
+ markerWidth := self hasMarker
+ ifTrue: [ self submorphBounds width + 8 ]
+ ifFalse: [ 0 ].
+ ^(self fontToUse widthOfString: contents)
+ + subMenuWidth + iconWidth + markerWidth!
Item was added:
+ ----- Method: MenuItemMorph>>mouseDown: (in category 'events') -----
+ mouseDown: evt
+ "Handle a mouse down event. Menu items get activated when the mouse is over them."
+
+ evt shiftPressed ifTrue: [ ^super mouseDown: evt ]. "enable label editing"
+ evt hand newMouseFocus: owner. "Redirect to menu for valid transitions"
+ owner selectItem: self event: evt!
Item was added:
+ ----- Method: MenuItemMorph>>mouseEnter: (in category 'events') -----
+ mouseEnter: evt
+ "The mouse entered the receiver"
+
+ owner ifNotNil: [ owner stayUp ifFalse: [ self mouseEnterDragging: evt ] ]!
Item was added:
+ ----- Method: MenuItemMorph>>mouseEnterDragging: (in category 'events') -----
+ mouseEnterDragging: evt
+ "The mouse entered the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
+ evt hand mouseFocus == owner ifTrue:[owner selectItem: self event: evt]!
Item was added:
+ ----- Method: MenuItemMorph>>mouseLeave: (in category 'events') -----
+ mouseLeave: evt
+ "The mouse has left the interior of the receiver..."
+
+ owner ifNotNil: [owner stayUp ifFalse: [self mouseLeaveDragging: evt]]!
Item was added:
+ ----- Method: MenuItemMorph>>mouseLeaveDragging: (in category 'events') -----
+ mouseLeaveDragging: evt
+ "The mouse left the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
+
+ owner ifNil: [^self].
+ evt hand mouseFocus == owner ifFalse: [ ^self ].
+ lastMousePosition := evt position.
+ owner selectItem: nil event: evt!
Item was added:
+ ----- Method: MenuItemMorph>>mouseUp: (in category 'events') -----
+ mouseUp: evt
+ "Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
+
+ evt hand mouseFocus == owner ifFalse: [ ^self ].
+ self contentString ifNotNil: [
+ self contents: self contentString withMarkers: true inverse: true.
+ self refreshWorld.
+ (Delay forMilliseconds: 200) wait ].
+ self deselect: evt.
+ self invokeWithEvent: evt.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>notObsolete (in category 'private') -----
+ notObsolete
+ "Provide backward compatibility with messages being sent to the Hand. Remove this when no projects made prior to 2.9 are likely to be used. If this method is removed early, the worst that can happen is a notifier when invoking an item in an obsolete menu."
+
+ (HandMorph canUnderstand: (selector)) ifTrue: [^ true]. "a modern one"
+
+ self inform: 'This world menu is obsolete.
+ Please dismiss the menu and open a new one.'.
+ ^ false
+ !
Item was added:
+ ----- Method: MenuItemMorph>>noteNewOwner: (in category 'submorphs-accessing') -----
+ noteNewOwner: aMorph
+ "I have just been added as a submorph of aMorph"
+ super noteNewOwner: aMorph.
+
+ self updateLayoutInDockingBar!
Item was added:
+ ----- Method: MenuItemMorph>>offImage (in category 'private') -----
+ offImage
+ "Return the form to be used for indicating an '<off>' marker"
+ | form |
+ form := Form extent: (self fontToUse ascent-2) asPoint depth: 16.
+ (form getCanvas)
+ frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.9)
+ borderWidth: 1 borderColor: Color black.
+ ^form!
Item was added:
+ ----- Method: MenuItemMorph>>onImage (in category 'private') -----
+ onImage
+ "Return the form to be used for indicating an '<off>' marker"
+ | form |
+ form := Form extent: (self fontToUse ascent-2) asPoint depth: 16.
+ (form getCanvas)
+ frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.8)
+ borderWidth: 1 borderColor: Color black;
+ fillRectangle: (form boundingBox insetBy: 2) fillStyle: Color black.
+ ^form!
Item was added:
+ ----- Method: MenuItemMorph>>ownerChanged (in category 'change reporting') -----
+ ownerChanged
+ "The receiver's owner, some kind of a pasteup, has changed its
+ layout."
+ super ownerChanged.
+ self updateLayoutInDockingBar!
Item was added:
+ ----- Method: MenuItemMorph>>realSelector (in category 'browse') -----
+ realSelector
+ selector == #perform:orSendTo: ifTrue: [^arguments first].
+ ^selector!
Item was added:
+ ----- Method: MenuItemMorph>>releasesSelection: (in category 'events') -----
+ releasesSelection: evt
+ " Returns a boolean indicating that this menu item is ready to go deselected.
+ It answers false if the mouse is moving towards its submenu.
+ We check this by testing that the current mouse position lays in the triangle of
+ the last mouse position and the two corners of the submenu facing our menu item. "
+
+ | triangle submenuIsOnTheRightSide |
+ self hasSubMenu ifFalse: [
+ lastMousePosition := nil.
+ ^true ].
+ lastMousePosition ifNil: [
+ lastMousePosition := evt position.
+ ^false ].
+ submenuIsOnTheRightSide := self left < subMenu left.
+ triangle := {
+ lastMousePosition.
+ submenuIsOnTheRightSide
+ ifTrue: [ subMenu topLeft ]
+ ifFalse: [ subMenu topRight ].
+ submenuIsOnTheRightSide
+ ifTrue: [ subMenu bottomLeft ]
+ ifFalse: [ subMenu bottomRight ] }.
+ lastMousePosition := evt position.
+ (self triangle: triangle containsPoint: evt position)
+ ifTrue: [ ^false ]
+ ifFalse: [
+ lastMousePosition := nil.
+ ^true ]!
Item was added:
+ ----- Method: MenuItemMorph>>rightArrow (in category 'private') -----
+ rightArrow
+
+ ^ SubMenuMarker!
Item was added:
+ ----- Method: MenuItemMorph>>select: (in category 'selecting') -----
+ select: evt
+ self isSelected: true.
+ owner activeSubmenu: subMenu.
+ subMenu ifNotNil: [
+ subMenu delete.
+ subMenu
+ popUpAdjacentTo: self adjacentTo
+ forHand: evt hand
+ from: self.
+ subMenu selectItem: nil event: evt].!
Item was added:
+ ----- Method: MenuItemMorph>>selectionFillStyle (in category 'private') -----
+ selectionFillStyle
+ " Answer the fill style to use with the receiver is the selected
+ element "
+
+ | fill baseColor preferenced |
+ Display depth <= 2 ifTrue: [
+ ^Color gray ].
+ preferenced := Preferences menuSelectionColor.
+ preferenced notNil ifTrue: [ ^preferenced ].
+ baseColor := owner color negated.
+ MenuMorph gradientMenu ifFalse: [ ^baseColor ].
+ fill := GradientFillStyle ramp: {
+ 0.0 -> baseColor twiceLighter.
+ 1 -> baseColor twiceDarker }.
+ fill origin: self topLeft.
+ ^ fill!
Item was added:
+ ----- Method: MenuItemMorph>>selector (in category 'accessing') -----
+ selector
+
+ ^ selector
+ !
Item was added:
+ ----- Method: MenuItemMorph>>selector: (in category 'accessing') -----
+ selector: aSymbol
+
+ selector := aSymbol.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>subMenu (in category 'accessing') -----
+ subMenu
+
+ ^ subMenu
+ !
Item was added:
+ ----- Method: MenuItemMorph>>subMenu: (in category 'accessing') -----
+ subMenu: aMenuMorph
+
+ subMenu := aMenuMorph.
+ self changed.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>subMenuMarker (in category 'private') -----
+ subMenuMarker
+ "private - answer the form to be used as submenu marker"
+
+ ^self rightArrow!
Item was added:
+ ----- Method: MenuItemMorph>>subMenuUpdater:selector: (in category 'accessing') -----
+ subMenuUpdater: updater selector: selector
+
+ subMenu := self createUpdatingSubmenu.
+ subMenu updater: updater updateSelector: selector.
+ self changed.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>subMenuUpdater:selector:arguments: (in category 'accessing') -----
+ subMenuUpdater: updater selector: selector arguments: arguments
+
+ subMenu := self createUpdatingSubmenu.
+ subMenu updater: updater updateSelector: selector arguments: arguments.
+ self changed.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>target (in category 'accessing') -----
+ target
+
+ ^ target!
Item was added:
+ ----- Method: MenuItemMorph>>target: (in category 'accessing') -----
+ target: anObject
+
+ target := anObject.
+ !
Item was added:
+ ----- Method: MenuItemMorph>>triangle:containsPoint: (in category 'geometry-testing') -----
+ triangle: points containsPoint: p
+ " Computes if p is in the triangle defined by points.
+ p should be a Point, and points should be an array with three Points.
+ I took the algorithm from the bottom of this page:
+ http://www.blackpawn.com/texts/pointinpoly/default.html "
+
+ | a b c v0 v1 v2 dot00 dot01 dot02 dot11 dot12 denom invDenom u v |
+ a := points first.
+ b := points second.
+ c := points third.
+ " Compute vectors "
+ v0 := c - a.
+ v1 := b - a.
+ v2 := p - a.
+ " Compute dot products "
+ dot00 := v0 dotProduct: v0.
+ dot01 := v0 dotProduct: v1.
+ dot02 := v0 dotProduct: v2.
+ dot11 := v1 dotProduct: v1.
+ dot12 := v1 dotProduct: v2.
+ " Compute barycentric coordinates "
+ denom := dot00 * dot11 - (dot01 * dot01).
+ denom = 0 ifTrue: [ ^false ].
+ invDenom := 1 / denom.
+ u := (dot11 * dot02 - (dot01 * dot12)) * invDenom.
+ v := (dot00 * dot12 - (dot01 * dot02)) * invDenom.
+ " Check if point is in triangle "
+ ^u >= 0 and: [ v >= 0 and: [ u + v <= 1 ] ]!
Item was added:
+ ----- Method: MenuItemMorph>>upArrow (in category 'private') -----
+ upArrow
+ ^ ColorForm
+ mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 270)asFormOfDepth: 8)!
Item was added:
+ ----- Method: MenuItemMorph>>updateLayoutInDockingBar (in category 'private') -----
+ updateLayoutInDockingBar!
Item was added:
+ ----- Method: MenuItemMorph>>vResizing (in category 'layout-properties') -----
+ vResizing
+ "Default to #shrinkWrap"
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#shrinkWrap] ifNotNil:[props vResizing].!
Item was added:
+ ----- Method: MenuItemMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ target := deepCopier references at: target ifAbsent: [target].
+ arguments notNil ifTrue:
+ [arguments := arguments collect: [:each |
+ deepCopier references at: each ifAbsent: [each]]]!
Item was added:
+ ----- Method: MenuItemMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied
+ at all, but shared. Warning!!!! Every instance variable defined in
+ this class must be handled. We must also implement
+ veryDeepFixupWith:. See DeepCopier class comment."
+ super veryDeepInner: deepCopier.
+ isEnabled := isEnabled veryDeepCopyWith: deepCopier.
+ subMenu := subMenu veryDeepCopyWith: deepCopier.
+ isSelected := isSelected veryDeepCopyWith: deepCopier.
+ icon := icon veryDeepCopyWith: deepCopier.
+ "target := target. Weakly copied"
+ "selector := selector. a Symbol"
+ arguments := arguments.
+ lastMousePosition := nil!
Item was added:
+ ----- Method: MenuItemMorph>>wantsHaloFromClick (in category 'meta actions') -----
+ wantsHaloFromClick
+ "Only if I'm not a lonely submenu"
+ ^owner notNil and:[owner submorphs size > 1]!
Item was added:
+ Morph subclass: #MenuLineMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus'!
Item was added:
+ ----- Method: MenuLineMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | baseColor |
+ baseColor := Preferences menuColorFromWorld
+ ifTrue: [owner color twiceDarker]
+ ifFalse: [Preferences menuAppearance3d
+ ifTrue: [owner color]
+ ifFalse: [Preferences menuLineColor]].
+ Preferences menuAppearance3d
+ ifTrue: [
+ aCanvas
+ fillRectangle: (bounds topLeft corner: bounds rightCenter)
+ color: baseColor twiceDarker.
+
+ aCanvas
+ fillRectangle: (bounds leftCenter corner: bounds bottomRight)
+ color: baseColor twiceLighter]
+ ifFalse: [
+ aCanvas
+ fillRectangle: (bounds topLeft corner: bounds bottomRight)
+ color: baseColor]!
Item was added:
+ ----- Method: MenuLineMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ self hResizing: #spaceFill; vResizing: #spaceFill.!
Item was added:
+ ----- Method: MenuLineMorph>>minHeight (in category 'layout') -----
+ minHeight
+ "answer the receiver's minHeight"
+ ^ self isInDockingBar
+ ifTrue: [owner isVertical
+ ifTrue: [2]
+ ifFalse: [10]]
+ ifFalse: [2]!
Item was added:
+ ----- Method: MenuLineMorph>>minWidth (in category 'layout') -----
+ minWidth
+ "answer the receiver's minWidth"
+ ^ self isInDockingBar
+ ifTrue: [owner isVertical
+ ifTrue: [10]
+ ifFalse: [2]]
+ ifFalse: [10]!
Item was added:
+ ----- Method: MenuLineMorph>>noteNewOwner: (in category 'submorphs-accessing') -----
+ noteNewOwner: aMorph
+ "I have just been added as a submorph of aMorph"
+ super noteNewOwner: aMorph.
+ self updateLayoutInDockingBar!
Item was added:
+ ----- Method: MenuLineMorph>>ownerChanged (in category 'change reporting') -----
+ ownerChanged
+ "The receiver's owner, some kind of a pasteup, has changed its
+ layout."
+ super ownerChanged.
+ self updateLayoutInDockingBar!
Item was added:
+ ----- Method: MenuLineMorph>>updateLayoutInDockingBar (in category 'private') -----
+ updateLayoutInDockingBar
+ self isInDockingBar
+ ifFalse: [^ self].
+ ""
+ owner isVertical
+ ifFalse: [""
+ self hResizing: #shrinkWrap.
+ self vResizing: #spaceFill]
+ ifTrue: [""
+ self hResizing: #spaceFill.
+ self vResizing: #shrinkWrap].
+ self extent: self minWidth @ self minHeight!
Item was added:
+ AlignmentMorph subclass: #MenuMorph
+ instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu'
+ classVariableNames: 'CloseBoxImage CloseBoxImageFlat CloseBoxImageGradient GradientMenu PushPinImage RoundedMenuCorners'
+ poolDictionaries: ''
+ category: 'Morphic-Menus'!
+
+ !MenuMorph commentStamp: '<historical>' prior: 0!
+ Instance variables:
+ defaultTarget <Object> The default target for creating menu items
+ selectedItem <MenuItemMorph> The currently selected item in the receiver
+ stayUp <Boolean> True if the receiver should stay up after clicks
+ popUpOwner <MenuItemMorph> The menu item that automatically invoked the receiver, if any.
+ activeSubMenu <MenuMorph> The currently active submenu.!
Item was added:
+ ----- Method: MenuMorph class>>chooseFrom:lines:title: (in category 'utilities') -----
+ chooseFrom: aList lines: linesArray title: queryString
+ "Choose an item from the given list. Answer the index of the selected item."
+ "MenuMorph
+ chooseFrom: #('Hello' 'World' 'Here' 'We' 'Go')
+ lines: #(2 4)
+ title: 'What''s up?'"
+ | menu aBlock result |
+ (ProvideAnswerNotification signal: queryString) ifNotNil:[:answer |
+ 1 to: aList size do:[:i| (aList at: i) = answer ifTrue:[^i]].
+ ^0].
+ aBlock := [:v| result := v].
+ menu := self new.
+ menu addTitle: queryString.
+ 1 to: aList size do:[:i|
+ menu add: (aList at: i) asString target: aBlock selector: #value: argument: i.
+ (linesArray includes: i) ifTrue:[menu addLine]
+ ].
+ MenuIcons decorateMenu: menu.
+ result := 0.
+ menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true.
+ ^result!
Item was added:
+ ----- Method: MenuMorph class>>chooseFrom:values:lines:title: (in category 'utilities') -----
+ chooseFrom: aList values: valueList lines: linesArray title: queryString
+ "Choose an item from the given list. Answer the index of the selected item."
+ "MenuMorph
+ chooseFrom: #('Hello' 'World' 'Here' 'We' 'Go')
+ values: #('Hello' 'World' 'Here' 'We' 'Go')
+ lines: #(2 4)
+ title: 'What''s up?'"
+ | menu aBlock result |
+ (ProvideAnswerNotification signal: queryString) ifNotNil:[:answer |
+ 1 to: aList size do:[:i| (aList at: i) = answer ifTrue:[^answer]].
+ ^nil].
+ aBlock := [:v| result := v].
+ menu := self new.
+ menu addTitle: queryString.
+ 1 to: aList size do:[:i|
+ menu add: (aList at: i) asString target: aBlock selector: #value: argument: (valueList at: i).
+ (linesArray includes: i) ifTrue:[menu addLine]
+ ].
+ MenuIcons decorateMenu: menu.
+ result := nil.
+ menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true.
+ ^result!
Item was added:
+ ----- Method: MenuMorph class>>closeBoxImage (in category 'images') -----
+ closeBoxImage
+
+ ^ self gradientMenu
+ ifTrue: [self closeBoxImageGradient]
+ ifFalse: [self closeBoxImageFlat]!
Item was added:
+ ----- Method: MenuMorph class>>closeBoxImageFlat (in category 'images') -----
+ closeBoxImageFlat
+
+ ^ CloseBoxImageFlat ifNil: [CloseBoxImageFlat := SystemWindow closeBoxImageFlat]!
Item was added:
+ ----- Method: MenuMorph class>>closeBoxImageGradient (in category 'images') -----
+ closeBoxImageGradient
+
+ ^ CloseBoxImageGradient ifNil: [CloseBoxImageGradient := SystemWindow closeBoxImageGradient]!
Item was added:
+ ----- Method: MenuMorph class>>confirm: (in category 'utilities') -----
+ confirm: queryString
+ "Put up a yes/no menu with caption queryString. Answer true if the
+ response is yes, false if no. This is a modal question--the user must
+ respond yes or no."
+
+ "MenuMorph confirm: 'Are you hungry?'"
+
+ ^ self confirm: queryString trueChoice: 'Yes' translated falseChoice: 'No' translated!
Item was added:
+ ----- Method: MenuMorph class>>confirm:orCancel: (in category 'utilities') -----
+ confirm: queryString orCancel: cancelBlock
+ "Put up a yes/no/cancel menu with caption aString. Answer true if the response is yes, false if no. If cancel is chosen, evaluate cancelBlock. This is a modal question--the user must respond yes or no."
+ "MenuMorph confirm: 'Reboot universe' orCancel:[^'Nevermind'] "
+ | choice |
+ choice := self chooseFrom: {'Yes' translated. 'No' translated. 'Cancel' translated}
+ lines: #()
+ title: queryString.
+ choice = 1 ifTrue: [^ true].
+ choice = 2 ifTrue: [^ false].
+ ^ cancelBlock value!
Item was added:
+ ----- Method: MenuMorph class>>confirm:trueChoice:falseChoice: (in category 'utilities') -----
+ confirm: queryString trueChoice: trueChoice falseChoice: falseChoice
+ "Put up a yes/no menu with caption queryString. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it's the false-choice. This is a modal question -- the user must respond one way or the other."
+ "MenuMorph
+ confirm: 'Are you hungry?'
+ trueChoice: 'yes, I''m famished'
+ falseChoice: 'no, I just ate'"
+ | menu aBlock result |
+ (ProvideAnswerNotification signal: queryString)
+ ifNotNil:[:answer | ^ trueChoice = answer].
+ aBlock := [:v| result := v].
+ menu := self new.
+ menu addTitle: queryString icon: MenuIcons confirmIcon.
+ menu add: trueChoice target: aBlock selector: #value: argument: true.
+ menu add: falseChoice target: aBlock selector: #value: argument: false.
+ MenuIcons decorateMenu: menu.
+ [menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true.
+ result == nil] whileTrue.
+ ^result!
Item was added:
+ ----- Method: MenuMorph class>>entitled: (in category 'instance creation') -----
+ entitled: aString
+ "Answer a new instance of me with the given title."
+
+ ^ self new addTitle: aString
+ !
Item was added:
+ ----- Method: MenuMorph class>>example (in category 'example') -----
+ example
+ "MenuMorph example popUpInWorld"
+
+ | menu |
+ menu := MenuMorph new.
+ menu addTitle: 'Fruit' translated.
+ menu addStayUpItem.
+ menu add: 'apples' action: #apples.
+ menu add: 'oranges' action: #oranges.
+ menu addLine.
+ menu addLine. "extra lines ignored"
+ menu add: 'peaches' action: #peaches.
+ menu addLine.
+ menu add: 'pears' action: #pears.
+ menu addLine.
+ ^ menu
+ !
Item was added:
+ ----- Method: MenuMorph class>>fromArray: (in category 'instance creation') -----
+ fromArray: anArray
+ "Construct a menu from anArray. The elements of anArray
+ must be either:
+ * A pair of the form: <label> <selector>
+ or * The 'dash' (or 'minus sign') symbol
+
+ Refer to the example at the bottom of the method"
+ | menu |
+
+ menu := self new.
+
+ anArray
+ do: [:anElement |
+ anElement size = 1
+ ifTrue: [
+ anElement == #- ifFalse: [^ self error: 'badly-formed menu constructor'].
+ menu addLine.
+ ]
+ ifFalse: [
+ anElement size = 2 ifFalse: [^ self error: 'badly-formed menu constructor'].
+ menu add: anElement first action: anElement second.
+ ]
+ ].
+
+ ^ menu!
Item was added:
+ ----- Method: MenuMorph class>>gradientMenu (in category 'preferences') -----
+ gradientMenu
+
+ <preference: 'gradientMenu'
+ category: #menus
+ description: 'If true, the menus will have a gradient look.'
+ type: #Boolean>
+ ^ GradientMenu ifNil: [true]!
Item was added:
+ ----- Method: MenuMorph class>>gradientMenu: (in category 'preferences') -----
+ gradientMenu: aBoolean
+
+ GradientMenu := aBoolean.
+ SystemProgressMorph reset.
+
+ "Update docking bars and their sub-menus."
+ ActiveWorld mainDockingBars do: [:bar |
+ bar
+ autoGradient: aBoolean;
+ updateColor].
+ TheWorldMainDockingBar updateInstances.!
Item was added:
+ ----- Method: MenuMorph class>>inform: (in category 'utilities') -----
+ inform: queryString
+ "MenuMorph inform: 'I like Squeak'"
+ | menu |
+ (ProvideAnswerNotification signal: queryString)
+ ifNotNil:[:answer | ^ self].
+ menu := self new.
+ menu addTitle: queryString icon: MenuIcons confirmIcon.
+ menu add: 'OK' target: self selector: #yourself.
+ MenuIcons decorateMenu: menu.
+ menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true.!
Item was added:
+ ----- Method: MenuMorph class>>initialize (in category 'instance creation') -----
+ initialize
+
+ "MenuMorph initialize"
+ CloseBoxImage := nil.
+ PushPinImage := nil.
+
+ !
Item was added:
+ ----- Method: MenuMorph class>>pushPinImage (in category 'images') -----
+ pushPinImage
+ "Answer the push-pin image, creating and caching it at this time if it is absent"
+
+ ^ MenuIcons smallPinIcon!
Item was added:
+ ----- Method: MenuMorph class>>roundedMenuCorners (in category 'preferences') -----
+ roundedMenuCorners
+
+ <preference: 'roundedMenuCorners'
+ category: #menus
+ description: 'Whether morphic menus should have rounded corners.'
+ type: #Boolean>
+ ^ RoundedMenuCorners ifNil: [true]!
Item was added:
+ ----- Method: MenuMorph class>>roundedMenuCorners: (in category 'preferences') -----
+ roundedMenuCorners: aBoolean
+
+ RoundedMenuCorners := aBoolean.
+ SystemProgressMorph reset.
+ TheWorldMainDockingBar updateInstances.!
Item was added:
+ ----- Method: MenuMorph>>activate: (in category 'events') -----
+ activate: evt
+ "Receiver should be activated; e.g., so that control passes correctly."
+ evt hand
+ newMouseFocus: self;
+ newKeyboardFocus: self!
Item was added:
+ ----- Method: MenuMorph>>activeSubmenu: (in category 'control') -----
+ activeSubmenu: aSubmenu
+ activeSubMenu ifNotNil: [
+ activeSubMenu delete ].
+ activeSubMenu := aSubmenu.
+ activeSubMenu ifNotNil: [
+ activeSubMenu updateMenu ]!
Item was added:
+ ----- Method: MenuMorph>>add:action: (in category 'construction') -----
+ add: aString action: aSymbolOrValuable
+ "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object."
+ "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action."
+ aSymbolOrValuable isSymbol
+ ifTrue:
+ [ self
+ add: aString
+ target: defaultTarget
+ selector: aSymbolOrValuable
+ argumentList: Array empty ]
+ ifFalse:
+ [ self
+ add: aString
+ target: aSymbolOrValuable
+ selector: #value
+ argumentList: Array empty ]!
Item was added:
+ ----- Method: MenuMorph>>add:help:action: (in category 'construction') -----
+ add: wordingString help: helpString action: aSymbol
+ "Append a menu item with the given label. If the item is
+ selected, it will send the given selector to the default target
+ object."
+ "Details: Note that the menu item added captures the default
+ target object at the time the item is added; the default target
+ can later be changed before added additional items without
+ affecting the targets of previously added entries. The model is
+ that each entry is like a button that knows everything it needs
+ to perform its action."
+ self
+ add: wordingString
+ target: defaultTarget
+ selector: aSymbol
+ argumentList: Array empty.
+ self balloonTextForLastItem:helpString!
Item was added:
+ ----- Method: MenuMorph>>add:icon:help:subMenu: (in category 'construction') -----
+ add: wordingString icon: aForm help: helpString subMenu: aMenuMorph
+ "Append the given submenu with the given label."
+ | item |
+ item := MenuItemMorph new.
+
+ item contents: wordingString.
+ item subMenu: aMenuMorph.
+ item icon: aForm.
+ helpString isNil
+ ifFalse: [item setBalloonText: helpString].
+ self addMorphBack: item!
Item was added:
+ ----- Method: MenuMorph>>add:icon:subMenu: (in category 'construction') -----
+ add: wordingString icon: aForm subMenu: aMenuMorph
+ "Append the given submenu with the given label."
+ ^ self
+ add: wordingString
+ icon: aForm
+ help: nil
+ subMenu: aMenuMorph!
Item was added:
+ ----- Method: MenuMorph>>add:selector:argument: (in category 'construction') -----
+ add: aString selector: aSymbol argument: arg
+
+ self add: aString
+ target: defaultTarget
+ selector: aSymbol
+ argumentList: (Array with: arg)
+ !
Item was added:
+ ----- Method: MenuMorph>>add:subMenu: (in category 'construction') -----
+ add: aString subMenu: aMenuMorph
+ "Append the given submenu with the given label."
+ self
+ add: aString
+ icon: nil
+ subMenu: aMenuMorph!
Item was added:
+ ----- Method: MenuMorph>>add:subMenu:target:selector:argumentList: (in category 'construction') -----
+ add: aString subMenu: aMenuMorph target: target selector: aSymbol argumentList: argList
+ "Append the given submenu with the given label."
+
+ | item |
+ item := MenuItemMorph new.
+ item
+ contents: aString;
+ target: target;
+ selector: aSymbol;
+ arguments: argList asArray;
+ subMenu: aMenuMorph.
+ self addMorphBack: item.
+ ^item!
Item was added:
+ ----- Method: MenuMorph>>add:target:action: (in category 'construction') -----
+ add: aString target: aTarget action: aSymbol
+ self
+ add: aString
+ target: aTarget
+ selector: aSymbol
+ argumentList: Array empty!
Item was added:
+ ----- Method: MenuMorph>>add:target:selector: (in category 'construction') -----
+ add: aString target: anObject selector: aSymbol
+ "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object."
+ self
+ add: aString
+ target: anObject
+ selector: aSymbol
+ argumentList: Array empty!
Item was added:
+ ----- Method: MenuMorph>>add:target:selector:argument: (in category 'construction') -----
+ add: aString target: target selector: aSymbol argument: arg
+ "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument."
+
+ self add: aString
+ target: target
+ selector: aSymbol
+ argumentList: (Array with: arg)
+ !
Item was added:
+ ----- Method: MenuMorph>>add:target:selector:argumentList: (in category 'construction') -----
+ add: aString target: target selector: aSymbol argumentList: argList
+ "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument."
+
+ | item |
+ item := MenuItemMorph new
+ contents: aString;
+ target: target;
+ selector: aSymbol;
+ arguments: argList asArray.
+ self addMorphBack: item.
+ !
Item was added:
+ ----- Method: MenuMorph>>addAllFrom: (in category 'construction') -----
+ addAllFrom: aMenuMorph
+ aMenuMorph submorphs
+ do: [:each |
+ (each isKindOf: MenuItemMorph)
+ ifTrue: [self
+ add: each contents
+ target: each target
+ selector: each selector
+ argumentList: each arguments].
+ (each isKindOf: MenuLineMorph)
+ ifTrue: [self addLine]] !
Item was added:
+ ----- Method: MenuMorph>>addBlankIconsIfNecessary: (in category 'accessing') -----
+ addBlankIconsIfNecessary: anIcon
+ "If any of my items have an icon, ensure that all do by using
+ anIcon for those that don't"
+ self items
+ reject: [:each | each hasIconOrMarker]
+ thenDo: [:each | each icon: anIcon]!
Item was added:
+ ----- Method: MenuMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu addLine.
+ aCustomMenu add: 'add title...' translated action: #addTitle.
+ aCustomMenu add: 'set target...' translated action: #setTarget:.
+ defaultTarget ifNotNil: [
+ aCustomMenu add: 'add item...' translated action: #addItem].
+ aCustomMenu add: 'add line' translated action: #addLine.
+ (self items count:[:any| any hasSubMenu]) > 0
+ ifTrue:[aCustomMenu add: 'detach submenu' translated action: #detachSubMenu:].!
Item was added:
+ ----- Method: MenuMorph>>addItem (in category 'menu') -----
+ addItem
+
+ | string sel |
+ string := UIManager default request: 'Label for new item?'.
+ string isEmpty ifTrue: [^ self].
+ sel := UIManager default request: 'Selector?'.
+ sel isEmpty ifFalse: [sel := sel asSymbol].
+ self add: string action: sel.
+ !
Item was added:
+ ----- Method: MenuMorph>>addItem: (in category 'construction') -----
+ addItem: aBlock
+ | item |
+ item := MenuItemMorph new.
+ aBlock value: item.
+ self addMenuItem: item!
Item was added:
+ ----- Method: MenuMorph>>addLine (in category 'construction') -----
+ addLine
+ "Append a divider line to this menu. Suppress duplicate lines."
+ self hasItems
+ ifFalse: [^ self].
+ (self lastSubmorph isKindOf: MenuLineMorph)
+ ifFalse: [self addMorphBack: MenuLineMorph new] !
Item was added:
+ ----- Method: MenuMorph>>addList: (in category 'construction') -----
+ addList: aList
+ "Add the given items to this menu, where each item is a pair (<string> <actionSelector>).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help."
+
+ aList do: [:tuple |
+ (tuple == #-)
+ ifTrue: [self addLine]
+ ifFalse:
+ [self add: tuple first action: tuple second.
+ tuple size > 2 ifTrue:
+ [self balloonTextForLastItem: tuple third]]]!
Item was added:
+ ----- Method: MenuMorph>>addMenuItem: (in category 'construction') -----
+ addMenuItem: aMenuItemMorph
+ self addMorphBack: aMenuItemMorph!
Item was added:
+ ----- Method: MenuMorph>>addService:for: (in category 'construction') -----
+ addService: aService for: serviceUser
+ "Append a menu item with the given service. If the item is selected, it will perform the given service."
+
+ aService addServiceFor: serviceUser toMenu: self.!
Item was added:
+ ----- Method: MenuMorph>>addServices2:for:extraLines: (in category 'construction') -----
+ addServices2: services for: served extraLines: linesArray
+
+ services withIndexDo: [:service :i |
+ service addServiceFor: served toMenu: self.
+ self lastItem setBalloonText: service description.
+ (linesArray includes: i) ifTrue: [self addLine] ]
+ !
Item was added:
+ ----- Method: MenuMorph>>addServices:for:extraLines: (in category 'construction') -----
+ addServices: services for: served extraLines: linesArray
+
+ services withIndexDo: [:service :i |
+ self addService: service for: served.
+ submorphs last setBalloonText: service description.
+ (linesArray includes: i) | service useLineAfter
+ ifTrue: [self addLine]].
+ !
Item was added:
+ ----- Method: MenuMorph>>addStayUpIcons (in category 'construction') -----
+ addStayUpIcons
+ | title closeBox pinBox titleBarArea titleString |
+ title := submorphs
+ detect: [:ea | ea hasProperty: #titleString]
+ ifNone: [self setProperty: #needsTitlebarWidgets toValue: true.
+ ^ self].
+ closeBox := SystemWindowButton new target: self;
+ actionSelector: #delete;
+ labelGraphic: self class closeBoxImage;
+ color: Color transparent;
+ extent: self class closeBoxImage extent;
+ borderWidth: 0.
+ pinBox := SystemWindowButton new target: self;
+ actionSelector: #stayUp:;
+ arguments: {true};
+ labelGraphic: self class pushPinImage;
+ color: Color transparent;
+ extent: self class pushPinImage extent;
+ borderWidth: 0.
+ Preferences noviceMode
+ ifTrue: [closeBox setBalloonText: 'close this menu'.
+ pinBox setBalloonText: 'keep this menu up'].
+ titleBarArea := AlignmentMorph newRow vResizing: #shrinkWrap;
+ layoutInset: 3;
+ color: Preferences menuTitleColor;
+ addMorphBack: closeBox;
+ addMorphBack: title;
+ addMorphBack: pinBox.
+
+ title color: Color transparent.
+
+ titleString := title
+ findDeepSubmorphThat: [:each | each respondsTo: #font: ]
+ ifAbsent: [StringMorph contents: String empty].
+ titleString font: Preferences windowTitleFont.
+ self wantsRoundedCorners
+ ifTrue: [titleBarArea useRoundedCorners].
+
+ self addMorphFront: titleBarArea.
+ titleBarArea setProperty: #titleString toValue: (title valueOfProperty: #titleString).
+ title removeProperty: #titleString.
+ self setProperty: #hasTitlebarWidgets toValue: true.
+ self removeProperty: #needsTitlebarWidgets.
+ self removeStayUpItems!
Item was added:
+ ----- Method: MenuMorph>>addStayUpItem (in category 'construction') -----
+ addStayUpItem
+ "Append a menu item that can be used to toggle this menu's persistence."
+
+ (self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ])
+ ifTrue: [ ^self ].
+ self addStayUpIcons.!
Item was added:
+ ----- Method: MenuMorph>>addStayUpItemSpecial (in category 'construction') -----
+ addStayUpItemSpecial
+ "Append a menu item that can be used to toggle this menu's persistent."
+
+ "This variant is resistant to the MVC compatibility in #setInvokingView:"
+
+ (self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ])
+ ifTrue: [ ^self ].
+ self addStayUpIcons.!
Item was added:
+ ----- Method: MenuMorph>>addTitle (in category 'menu') -----
+ addTitle
+
+ | string |
+ string := UIManager default request: 'Title for this menu?'.
+ string isEmpty ifTrue: [^ self].
+ self addTitle: string.
+ !
Item was added:
+ ----- Method: MenuMorph>>addTitle: (in category 'construction') -----
+ addTitle: aString
+ "Add a title line at the top of this menu."
+
+ self addTitle: aString updatingSelector: nil updateTarget: nil!
Item was added:
+ ----- Method: MenuMorph>>addTitle:icon: (in category 'construction') -----
+ addTitle: aString icon: aForm
+ "Add a title line at the top of this menu."
+ self
+ addTitle: aString
+ icon: aForm
+ updatingSelector: nil
+ updateTarget: nil !
Item was added:
+ ----- Method: MenuMorph>>addTitle:icon:updatingSelector:updateTarget: (in category 'construction') -----
+ addTitle: aString icon: aForm updatingSelector: aSelector updateTarget: aTarget
+ "Add a title line at the top of this menu Make aString its initial
+ contents.
+ If aSelector is not nil, then periodically obtain fresh values for
+ its
+ contents by sending aSelector to aTarget.."
+ | title titleContainer |
+ title := AlignmentMorph newColumn.
+ self setTitleParametersFor: title.
+ ""
+ aForm isNil
+ ifTrue: [titleContainer := title]
+ ifFalse: [| pair |
+ pair := AlignmentMorph newRow.
+
+ pair color: Color transparent.
+ pair hResizing: #shrinkWrap.
+ pair layoutInset: 0.
+ ""
+ pair addMorphBack: aForm asMorph.
+ ""
+ titleContainer := AlignmentMorph newColumn.
+ titleContainer color: Color transparent.
+ titleContainer vResizing: #shrinkWrap.
+ titleContainer wrapCentering: #center.
+ titleContainer cellPositioning: #topCenter.
+ titleContainer layoutInset: 0.
+ pair addMorphBack: titleContainer.
+ ""
+ title addMorphBack: pair].
+ ""
+ aSelector
+ ifNil: [""
+ aString asString
+ linesDo: [:line | titleContainer
+ addMorphBack: ((StringMorph
+ contents: line
+ font: Preferences standardMenuFont)
+ color: (Color black);
+ yourself)]]
+ ifNotNil: [| usm |
+ usm := UpdatingStringMorph on: aTarget selector: aSelector.
+ usm font: Preferences standardMenuFont.
+ usm useStringFormat.
+ usm lock.
+ titleContainer addMorphBack: usm].
+ ""
+ title setProperty: #titleString toValue: aString.
+ self addMorphFront: title.
+ ""
+ title useSquareCorners.
+ (self hasProperty: #needsTitlebarWidgets)
+ ifTrue: [self addStayUpIcons]!
Item was added:
+ ----- Method: MenuMorph>>addTitle:updatingSelector:updateTarget: (in category 'construction') -----
+ addTitle: aString updatingSelector: aSelector updateTarget: aTarget
+ "Add a title line at the top of this menu Make aString its initial
+ contents.
+ If aSelector is not nil, then periodically obtain fresh values for
+ its contents by sending aSelector to aTarget.."
+ ^ self
+ addTitle: aString
+ icon: nil
+ updatingSelector: aSelector
+ updateTarget: aTarget!
Item was added:
+ ----- Method: MenuMorph>>addTranslatedList: (in category 'construction') -----
+ addTranslatedList: aList
+ "Add the given items to this menu, where each item is a pair (<string> <actionSelector>).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help.
+ The first and third items will be translated."
+
+ aList do: [:tuple |
+ (tuple == #-)
+ ifTrue: [self addLine]
+ ifFalse:
+ [self add: tuple first translated action: tuple second.
+ tuple size > 2 ifTrue:
+ [self balloonTextForLastItem: tuple third translated ]]]!
Item was added:
+ ----- Method: MenuMorph>>addUpdating:action: (in category 'construction') -----
+ addUpdating: aWordingSelector action: aSymbol
+ self
+ addUpdating: aWordingSelector
+ target: defaultTarget
+ selector: aSymbol
+ argumentList: Array empty!
Item was added:
+ ----- Method: MenuMorph>>addUpdating:enablement:action: (in category 'construction') -----
+ addUpdating: aWordingSelector enablement: anEnablementSelector action: aSymbol
+ self
+ addUpdating: aWordingSelector
+ enablementSelector: anEnablementSelector
+ target: defaultTarget
+ selector: aSymbol
+ argumentList: Array empty!
Item was added:
+ ----- Method: MenuMorph>>addUpdating:enablementSelector:target:selector:argumentList: (in category 'construction') -----
+ addUpdating: wordingSelector enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList
+ "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, and the optional enablementSelector determines whether or not the item should be enabled. Answer the item itself."
+
+ | item |
+ item := UpdatingMenuItemMorph new
+ target: target;
+ selector: aSymbol;
+ wordingProvider: target wordingSelector: wordingSelector;
+ enablementSelector: enablementSelector;
+ arguments: argList asArray.
+ self addMorphBack: item.
+ ^ item
+ !
Item was added:
+ ----- Method: MenuMorph>>addUpdating:target:action: (in category 'construction') -----
+ addUpdating: aWordingSelector target: aTarget action: aSymbol
+ self
+ addUpdating: aWordingSelector
+ target: aTarget
+ selector: aSymbol
+ argumentList: Array empty!
Item was added:
+ ----- Method: MenuMorph>>addUpdating:target:selector:argumentList: (in category 'construction') -----
+ addUpdating: wordingSelector target: target selector: aSymbol argumentList: argList
+ "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, Answer the item added."
+
+ | item |
+ item := UpdatingMenuItemMorph new
+ target: target;
+ selector: aSymbol;
+ wordingProvider: target wordingSelector: wordingSelector;
+ arguments: argList asArray.
+ self addMorphBack: item.
+ ^ item
+ !
Item was added:
+ ----- Method: MenuMorph>>addWithLabel:enablement:action: (in category 'construction') -----
+ addWithLabel: aLabel enablement: anEnablementSelector action: aSymbol
+ self
+ addWithLabel: aLabel
+ enablementSelector: anEnablementSelector
+ target: defaultTarget
+ selector: aSymbol
+ argumentList: Array empty!
Item was added:
+ ----- Method: MenuMorph>>addWithLabel:enablementSelector:target:selector:argumentList: (in category 'construction') -----
+ addWithLabel: aLabel enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList
+ "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is constant, and the optional enablementSelector determines whether or not the item should be enabled."
+
+ | item |
+ item := UpdatingMenuItemMorph new
+ target: target;
+ selector: aSymbol;
+ contents: aLabel;
+ wordingProvider: target wordingSelector: nil;
+ enablementSelector: enablementSelector;
+ arguments: argList asArray.
+ self addMorphBack: item.
+ !
Item was added:
+ ----- Method: MenuMorph>>balloonTextForLastItem: (in category 'construction') -----
+ balloonTextForLastItem: balloonText
+ submorphs last setBalloonText: balloonText!
Item was added:
+ ----- Method: MenuMorph>>commandKeyHandler (in category 'accessing') -----
+ commandKeyHandler
+ "Answer the receiver's commandKeyHandler"
+
+ ^ self valueOfProperty: #commandKeyHandler ifAbsent: [nil]!
Item was added:
+ ----- Method: MenuMorph>>commandKeyHandler: (in category 'accessing') -----
+ commandKeyHandler: anObject
+ "Set the receiver's commandKeyHandler. Whatever you set here needs to be prepared to respond to the message #commandKeyTypedIntoMenu: "
+
+ self setProperty: #commandKeyHandler toValue: anObject!
Item was added:
+ ----- Method: MenuMorph>>deactivate: (in category 'events') -----
+ deactivate: evt
+
+ "If a stand-alone menu, just delete it"
+ popUpOwner ifNil: [
+ self delete.
+ ^true ].
+ "If a sub-menu, then deselect, and return focus to outer menu"
+ self selectItem: nil event: evt.
+ evt hand newMouseFocus: popUpOwner owner.
+ evt hand newKeyboardFocus: popUpOwner owner!
Item was added:
+ ----- Method: MenuMorph>>defaultTarget (in category 'accessing') -----
+ defaultTarget
+ ^defaultTarget!
Item was added:
+ ----- Method: MenuMorph>>defaultTarget: (in category 'construction') -----
+ defaultTarget: anObject
+ "Set the default target for adding menu items."
+
+ defaultTarget := anObject.
+ !
Item was added:
+ ----- Method: MenuMorph>>delete (in category 'initialization') -----
+ delete
+ activeSubMenu ifNotNil:[activeSubMenu delete].
+ ^super delete!
Item was added:
+ ----- Method: MenuMorph>>deleteIfPopUp (in category 'control') -----
+ deleteIfPopUp
+ "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu."
+
+ stayUp ifFalse: [self topRendererOrSelf delete].
+ (popUpOwner notNil and: [popUpOwner isKindOf: MenuItemMorph]) ifTrue: [
+ popUpOwner isSelected: false.
+ (popUpOwner owner isKindOf: MenuMorph)
+ ifTrue: [popUpOwner owner deleteIfPopUp]].
+ !
Item was added:
+ ----- Method: MenuMorph>>deleteIfPopUp: (in category 'control') -----
+ deleteIfPopUp: evt
+ "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu."
+
+ stayUp ifFalse: [self topRendererOrSelf delete].
+ (popUpOwner notNil) ifTrue: [
+ popUpOwner isSelected: false.
+ popUpOwner deleteIfPopUp: evt].
+ evt ifNotNil:[evt hand releaseMouseFocus: self].!
Item was added:
+ ----- Method: MenuMorph>>detachSubMenu: (in category 'menu') -----
+ detachSubMenu: evt
+ | possibleTargets item subMenu index |
+ possibleTargets := self items select:[:any| any hasSubMenu].
+ possibleTargets size > 0 ifTrue:[
+ index := UIManager default
+ chooseFrom: (possibleTargets collect:[:t| t contents asString])
+ title: 'Which menu?'.
+ index = 0 ifTrue:[^self]].
+ item := possibleTargets at: index.
+ subMenu := item subMenu.
+ subMenu ifNotNil: [
+ item subMenu: nil.
+ item delete.
+ subMenu stayUp: true.
+ subMenu popUpOwner: nil.
+ subMenu addTitle: item contents.
+ evt hand attachMorph: subMenu].
+ !
Item was added:
+ ----- Method: MenuMorph>>displayFiltered: (in category 'keyboard control') -----
+ displayFiltered: evt
+ | matchStr allItems matches feedbackMorph |
+ matchStr := self valueOfProperty: #matchString.
+ allItems := self submorphs select: [:m | m isKindOf: MenuItemMorph].
+ matches := allItems select: [:m | | isMatch |
+ isMatch :=
+ matchStr isEmpty or: [
+ m contents includesSubstring: matchStr caseSensitive: false].
+ m isEnabled: isMatch.
+ isMatch].
+ feedbackMorph := self valueOfProperty: #feedbackMorph.
+ feedbackMorph ifNil: [
+ feedbackMorph :=
+ TextMorph new
+ autoFit: true;
+ color: Color darkGray.
+ self
+ addLine;
+ addMorphBack: feedbackMorph lock.
+ self setProperty: #feedbackMorph toValue: feedbackMorph.
+ self fullBounds. "Lay out for submorph adjacency"].
+ feedbackMorph contents: '<', matchStr, '>'.
+ matchStr isEmpty ifTrue: [
+ feedbackMorph delete.
+ self submorphs last delete.
+ self removeProperty: #feedbackMorph].
+ " This method is invoked with evt = nil from MenuMorph >> removeMatchString.
+ The current implementation can't select an item without an event. "
+ (evt notNil and: [ matches size >= 1 ]) ifTrue: [
+ self selectItem: matches first event: evt]!
Item was added:
+ ----- Method: MenuMorph>>doButtonAction (in category 'menu') -----
+ doButtonAction
+ "Do the receiver's inherent button action. Makes sense for the kind of MenuMorph that is a wrapper for a single menu-item -- pass it on the the item"
+
+ (self findA: MenuItemMorph) ifNotNil: [:aMenuItem | aMenuItem doButtonAction]!
Item was added:
+ ----- Method: MenuMorph>>drawKeyboardFocusIndicationOn: (in category 'drawing') -----
+ drawKeyboardFocusIndicationOn: aCanvas
+ "Draw the menu. Add keyboard-focus feedback if appropriate"
+
+ (self rootMenu hasProperty: #hasUsedKeyboard)
+ ifTrue: [
+ aCanvas
+ frameRectangle: self innerBounds
+ width: Preferences menuBorderWidth
+ color: Preferences keyboardFocusColor].!
Item was added:
+ ----- Method: MenuMorph>>filterListWith: (in category 'keyboard control') -----
+ filterListWith: char
+ | matchString |
+ matchString := self valueOfProperty: #matchString ifAbsentPut: [String new].
+ matchString := char = Character backspace
+ ifTrue:
+ [matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]]
+ ifFalse: [matchString copyWith: char].
+ self setProperty: #matchString toValue: matchString!
Item was added:
+ ----- Method: MenuMorph>>handleCRStroke: (in category 'keystroke helpers') -----
+ handleCRStroke: evt
+
+ | selectable |
+ evt keyValue = 13 ifFalse: [ ^false ].
+ selectedItem ifNotNil: [
+ selectedItem hasSubMenu
+ ifTrue: [
+ evt hand
+ newMouseFocus: selectedItem subMenu;
+ newKeyboardFocus: selectedItem subMenu ]
+ ifFalse: [
+ selectedItem invokeWithEvent: evt ].
+ ^true ].
+ (selectable := self items) size = 1 ifTrue: [
+ selectable first invokeWithEvent: evt ].
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>handleCommandKeyPress: (in category 'keystroke helpers') -----
+ handleCommandKeyPress: evt
+
+ (evt commandKeyPressed and: [
+ self commandKeyHandler notNil ]) ifTrue: [
+ self commandKeyHandler commandKeyTypedIntoMenu: evt.
+ self deleteIfPopUp: evt.
+ ^true ].
+ ^false!
Item was added:
+ ----- Method: MenuMorph>>handleDownStroke: (in category 'keystroke helpers') -----
+ handleDownStroke: evt
+
+ evt keyValue = 31 ifFalse: [ ^false ].
+ self moveSelectionDown: 1 event: evt.
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>handleEscStroke: (in category 'keystroke helpers') -----
+ handleEscStroke: evt
+
+ evt keyValue = 27 ifFalse: [ ^false ].
+ self
+ valueOfProperty: #matchString
+ ifPresentDo: [ :str |
+ str isEmpty ifFalse: [ "If filtered, first ESC removes filter"
+ self setProperty: #matchString toValue: String new.
+ self selectItem: nil event: evt.
+ self displayFiltered: evt.
+ ^true ] ].
+ self deactivate: evt.
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>handleFiltering: (in category 'keystroke helpers') -----
+ handleFiltering: evt
+
+ | matchString |
+ matchString := self valueOfProperty: #matchString ifAbsentPut: [ String new ].
+ matchString := evt keyValue = 8 " Character backspace asciiValue "
+ ifTrue: [
+ matchString isEmpty
+ ifTrue: [ matchString ]
+ ifFalse: [ matchString allButLast ] ]
+ ifFalse: [
+ matchString copyWith: evt keyCharacter ].
+ self setProperty: #matchString toValue: matchString.
+ self displayFiltered: evt!
Item was added:
+ ----- Method: MenuMorph>>handleFocusEvent: (in category 'events') -----
+ handleFocusEvent: evt
+ "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children."
+ self processEvent: evt.
+
+ "Need to handle keyboard input if we have the focus."
+ evt isKeyboard ifTrue: [^ self handleEvent: evt].
+
+ "We need to handle button clicks outside and transitions to local popUps so throw away everything else"
+ (evt isMouseOver or:[evt isMouse not]) ifTrue:[^self].
+ "What remains are mouse buttons and moves"
+ evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means"
+ "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first."
+ selectedItem ifNotNil: [
+ (selectedItem activateSubmenu: evt)
+ ifTrue: [ ^self ]
+ ifFalse: [
+ (self containsPoint: evt position) ifFalse: [
+ self selectItem: nil event: evt ] ] ].
+ "Note: The following does not traverse upwards but it's the best I can do for now"
+ popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: evt) ifTrue:[^self]].!
Item was added:
+ ----- Method: MenuMorph>>handleLeftStroke: (in category 'keystroke helpers') -----
+ handleLeftStroke: evt
+
+ 28 = evt keyValue ifFalse: [ ^false ].
+ self stepIntoSubmenu: evt.
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>handleMouseMove: (in category 'events') -----
+ handleMouseMove: evt
+ " If the mouse moves over an item not selected, we try to set it as selected.
+ If this happens depends on that the current selected item wants to release
+ its selection. "
+
+ self selectedItem ifNil: [ ^super handleMouseMove: evt ].
+ (self selectedItem containsPoint: evt position) ifTrue: [ ^super handleMouseMove: evt ].
+ self
+ selectItem: (
+ self items
+ detect: [ :each | each containsPoint: evt position ]
+ ifNone: [ nil ])
+ event: evt.
+ super handleMouseMove: evt!
Item was added:
+ ----- Method: MenuMorph>>handlePageDownStorke: (in category 'keystroke helpers') -----
+ handlePageDownStorke: evt
+
+ evt keyValue = 12 ifFalse: [ ^false ].
+ self moveSelectionDown: 5 event: evt.
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>handlePageDownStroke: (in category 'keystroke helpers') -----
+ handlePageDownStroke: evt
+
+ evt keyValue = 12 ifFalse: [ ^false ].
+ self moveSelectionDown: 5 event: evt.
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>handlePageUpStroke: (in category 'keystroke helpers') -----
+ handlePageUpStroke: evt
+
+ evt keyValue = 11 ifFalse: [ ^false ].
+ self moveSelectionDown: -5 event: evt.
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>handleRightStroke: (in category 'keystroke helpers') -----
+ handleRightStroke: evt
+
+ 29 = evt keyValue ifFalse: [ ^false ].
+ self stepIntoSubmenu: evt.
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>handleUpStorke: (in category 'keystroke helpers') -----
+ handleUpStorke: evt
+
+ evt keyValue = 30 ifFalse: [ ^false ].
+ self moveSelectionDown: -1 event: evt.
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>handlesKeyboard: (in category 'keyboard control') -----
+ handlesKeyboard: evt
+ "Answer whether the receiver handles the keystroke represented by the event"
+
+ ^ evt anyModifierKeyPressed not or: [evt commandKeyPressed and: [self commandKeyHandler notNil]]!
Item was added:
+ ----- Method: MenuMorph>>handlesMouseDown: (in category 'events') -----
+ handlesMouseDown: evt
+ ^true!
Item was added:
+ ----- Method: MenuMorph>>hasItems (in category 'accessing') -----
+ hasItems
+ "Answer if the receiver has menu items"
+ ^ submorphs
+ anySatisfy: [:each | each isKindOf: MenuItemMorph] !
Item was added:
+ ----- Method: MenuMorph>>hasSubMenu: (in category 'accessing') -----
+ hasSubMenu: aMenuMorph
+ self items do: [:each | (each hasSubMenu: aMenuMorph) ifTrue:[^true]].
+ ^ false
+ !
Item was added:
+ ----- Method: MenuMorph>>hideKeyboardHelp (in category 'keystroke helpers') -----
+ hideKeyboardHelp
+ self deleteBalloon!
Item was added:
+ ----- Method: MenuMorph>>indicateKeyboardFocus (in category 'testing') -----
+ indicateKeyboardFocus
+
+ ^ true!
Item was added:
+ ----- Method: MenuMorph>>informUserAt:during: (in category 'modal control') -----
+ informUserAt: aPoint during: aBlock
+ "Add this menu to the Morphic world during the execution of the given block."
+ | title w |
+ title := self allMorphs detect: [ :ea | ea hasProperty: #titleString ].
+ title := title submorphs first.
+ self visible: false.
+ w := ActiveWorld.
+ aBlock value:[:string|
+ self visible ifFalse:[
+ w addMorph: self centeredNear: aPoint.
+ self visible: true].
+ title contents: string.
+ self setConstrainedPosition: Sensor cursorPoint hangOut: false.
+ self changed.
+ w displayWorld "show myself"
+ ].
+ self delete.
+ w displayWorld!
Item was added:
+ ----- Method: MenuMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+
+ bounds := 0 @ 0 corner: 40 @ 10.
+
+ self setDefaultParameters.
+
+ self listDirection: #topToBottom.
+ self hResizing: #shrinkWrap.
+ self vResizing: #shrinkWrap.
+ defaultTarget := nil.
+ selectedItem := nil.
+ stayUp := false.
+ popUpOwner := nil.!
Item was added:
+ ----- Method: MenuMorph>>invokeAt:in:allowKeyboard: (in category 'modal control') -----
+ invokeAt: aPoint in: aWorld allowKeyboard: aBoolean
+ "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu."
+ "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."
+ | w originalFocusHolder |
+ originalFocusHolder := aWorld primaryHand keyboardFocus.
+ self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean.
+ w := aWorld outermostWorldMorph. "containing hand"
+ [self isInWorld] whileTrue: [w doOneSubCycle].
+ self delete.
+ originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder].
+ !
Item was added:
+ ----- Method: MenuMorph>>invokeMetaMenu: (in category 'private') -----
+ invokeMetaMenu: evt
+ stayUp ifFalse:[^self]. "Don't allow this"
+ ^super invokeMetaMenu: evt!
Item was added:
+ ----- Method: MenuMorph>>invokeModal (in category 'modal control') -----
+ invokeModal
+ "Invoke this menu and don't return until the user has chosen a value.
+ See example below on how to use modal menu morphs."
+ ^ self invokeModal: Preferences menuKeyboardControl
+
+ "Example:
+ | menu sub entry |
+ menu := MenuMorph new.
+ 1 to: 3 do: [:i |
+ entry := 'Line', i printString.
+ sub := MenuMorph new.
+ menu add: entry subMenu: sub.
+ #('Item A' 'Item B' 'Item C') do:[:subEntry|
+ sub add: subEntry target: menu
+ selector: #modalSelection: argument: {entry. subEntry}]].
+ menu invokeModal.
+ "
+
+ !
Item was added:
+ ----- Method: MenuMorph>>invokeModal: (in category 'modal control') -----
+ invokeModal: allowKeyboardControl
+ "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu"
+
+ ^ self invokeModalAt: ActiveHand position in: ActiveWorld allowKeyboard: allowKeyboardControl!
Item was added:
+ ----- Method: MenuMorph>>invokeModalAt:in: (in category 'modal control') -----
+ invokeModalAt: aPoint in: aWorld
+ "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu."
+ "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."
+
+ ^ self invokeModalAt: aPoint in: aWorld allowKeyboard: Preferences menuKeyboardControl!
Item was added:
+ ----- Method: MenuMorph>>invokeModalAt:in:allowKeyboard: (in category 'modal control') -----
+ invokeModalAt: aPoint in: aWorld allowKeyboard: aBoolean
+ "Invoke this menu and don't return until the user has chosen a value.
+ See senders of this method for finding out how to use modal menu morphs."
+ | w originalFocusHolder |
+ originalFocusHolder := aWorld primaryHand keyboardFocus.
+ self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean.
+ self isModalInvokationDone: false.
+ w := aWorld outermostWorldMorph. "containing hand"
+ [self isInWorld & self isModalInvokationDone not] whileTrue: [w doOneSubCycle].
+ self delete.
+ originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder].
+ ^ self modalSelection!
Item was added:
+ ----- Method: MenuMorph>>isModalInvokationDone (in category 'modal control') -----
+ isModalInvokationDone
+ ^self valueOfProperty: #isModalInvokationDone ifAbsent:[false]!
Item was added:
+ ----- Method: MenuMorph>>isModalInvokationDone: (in category 'modal control') -----
+ isModalInvokationDone: aBool
+ self setProperty: #isModalInvokationDone toValue: aBool
+ !
Item was added:
+ ----- Method: MenuMorph>>itemWithWording: (in category 'accessing') -----
+ itemWithWording: wording
+ "If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil."
+
+ self items do:[:anItem | | found |
+ found := anItem itemWithWording: wording.
+ found ifNotNil:[^found]].
+ ^ nil!
Item was added:
+ ----- Method: MenuMorph>>items (in category 'accessing') -----
+ items
+
+ ^ submorphs select: [:m | m isKindOf: MenuItemMorph]
+ !
Item was added:
+ ----- Method: MenuMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: aMorph event: evt
+ | halo |
+ super justDroppedInto: aMorph event: evt.
+ halo := evt hand halo.
+ (halo notNil and:[halo target hasOwner: self]) ifTrue:[
+ "Grabbed single menu item"
+ self addHalo: evt.
+ ].
+ stayUp ifFalse:[evt hand newMouseFocus: self].!
Item was added:
+ ----- Method: MenuMorph>>keyStroke: (in category 'keyboard control') -----
+ keyStroke: evt
+ self hideKeyboardHelp; noteRootMenuHasUsedKeyboard.
+ self keyStrokeHandlers
+ detect: [:each | self perform: each with: evt]
+ ifNone: [self handleFiltering: evt]!
Item was added:
+ ----- Method: MenuMorph>>keyStrokeHandlers (in category 'keystroke helpers') -----
+ keyStrokeHandlers
+
+ ^#(
+ handleCommandKeyPress:
+ handleCRStroke:
+ handleEscStroke:
+ handleLeftStroke:
+ handleRightStroke:
+ handleUpStorke:
+ handleDownStroke:
+ handlePageUpStroke:
+ handlePageDownStroke:)!
Item was added:
+ ----- Method: MenuMorph>>labels:lines:selections: (in category 'construction') -----
+ labels: labelList lines: linesArray selections: selectionsArray
+ "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:."
+
+ "Labels can be either a sting with embedded crs, or a collection of strings."
+
+ | labelArray |
+ labelArray := (labelList isString)
+ ifTrue: [labelList lines]
+ ifFalse: [labelList].
+ 1 to: labelArray size
+ do:
+ [:i |
+ self add: (labelArray at: i) action: (selectionsArray at: i).
+ (linesArray includes: i) ifTrue: [self addLine]]!
Item was added:
+ ----- Method: MenuMorph>>lastItem (in category 'accessing') -----
+ lastItem
+
+ submorphs reverseDo: [ :each |
+ (each isKindOf: MenuItemMorph) ifTrue: [ ^each ] ].
+ ^submorphs last!
Item was added:
+ ----- Method: MenuMorph>>lastSelection (in category 'accessing') -----
+ lastSelection
+ "Return the label of the last selected item or nil."
+
+ ^selectedItem ifNotNil: [selectedItem selector]!
Item was added:
+ ----- Method: MenuMorph>>modalSelection (in category 'modal control') -----
+ modalSelection
+ ^self valueOfProperty: #modalSelection ifAbsent:[nil]!
Item was added:
+ ----- Method: MenuMorph>>modalSelection: (in category 'modal control') -----
+ modalSelection: anObject
+ self setProperty: #modalSelection toValue: anObject.
+ self isModalInvokationDone: true!
Item was added:
+ ----- Method: MenuMorph>>morphicLayerNumber (in category 'private') -----
+ morphicLayerNumber
+
+ "helpful for insuring some morphs always appear in front of or behind others.
+ smaller numbers are in front"
+ ^self valueOfProperty: #morphicLayerNumber ifAbsent: [
+ stayUp ifTrue:[100] ifFalse:[10]
+ ]!
Item was added:
+ ----- Method: MenuMorph>>mouseDown: (in category 'events') -----
+ mouseDown: evt
+ "Handle a mouse down event."
+ (stayUp or:[self fullContainsPoint: evt position])
+ ifFalse:[^self deleteIfPopUp: evt]. "click outside"
+ self isSticky ifTrue: [^self].
+ "Grab the menu and drag it to some other place"
+ evt hand grabMorph: self.!
Item was added:
+ ----- Method: MenuMorph>>mouseUp: (in category 'events') -----
+ mouseUp: evt
+ "Handle a mouse up event.
+ Note: This might be sent from a modal shell."
+ (self fullContainsPoint: evt position) ifFalse:[
+ "Mouse up outside. Release eventual focus and delete if pop up."
+ evt hand releaseMouseFocus: self.
+ ^self deleteIfPopUp: evt].
+ stayUp ifFalse:[
+ "Still in pop-up transition; keep focus"
+ evt hand newMouseFocus: self].!
Item was added:
+ ----- Method: MenuMorph>>moveSelectionDown:event: (in category 'keyboard control') -----
+ moveSelectionDown: direction event: evt
+ "Move the current selection up or down by one, presumably under keyboard control.
+ direction = +/-1"
+
+ | index |
+ index := (submorphs indexOf: selectedItem ifAbsent: [1-direction]) + direction.
+ submorphs do: "Ensure finite"
+ [:unused | | m |
+ m := submorphs atWrap: index.
+ ((m isKindOf: MenuItemMorph) and: [m isEnabled]) ifTrue:
+ [^ self selectItem: m event: evt].
+ "Keep looking for an enabled item"
+ index := index + direction sign].
+ ^ self selectItem: nil event: evt!
Item was added:
+ ----- Method: MenuMorph>>noteRootMenuHasUsedKeyboard (in category 'keystroke helpers') -----
+ noteRootMenuHasUsedKeyboard
+
+ (self rootMenu hasProperty: #hasUsedKeyboard) ifFalse: [
+ self setProperty: #hasUsedKeyboard toValue: true.
+ self changed ].!
Item was added:
+ ----- Method: MenuMorph>>popUpAdjacentTo:forHand:from: (in category 'control') -----
+ popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem
+ "Present this menu at the given point under control of the given hand."
+
+ | tryToPlace selectedOffset rightPoint leftPoint |
+ hand world startSteppingSubmorphsOf: self.
+ popUpOwner := sourceItem.
+
+ self fullBounds.
+ self updateColor.
+
+ "ensure layout is current"
+ selectedOffset := (selectedItem
+ ifNil: [self items first]) position - self position.
+ tryToPlace := [:where :mustFit | | delta |
+ self position: where - selectedOffset.
+ delta := self boundsInWorld amountToTranslateWithin: sourceItem worldBounds.
+ (delta x = 0
+ or: [mustFit])
+ ifTrue: [delta = (0 @ 0)
+ ifFalse: [self position: self position + delta].
+ sourceItem owner owner addMorphFront: self.
+ ^ self]].
+ rightPoint := rightOrLeftPoint first + ((self layoutInset + self borderWidth) @ 0).
+ leftPoint := rightOrLeftPoint last - ((self layoutInset + self borderWidth + self width) @ 0).
+ tryToPlace
+ value: rightPoint value: false;
+ value: leftPoint value: false;
+ value: rightPoint value: true.!
Item was added:
+ ----- Method: MenuMorph>>popUpAt:forHand:in: (in category 'control') -----
+ popUpAt: aPoint forHand: hand in: aWorld
+ "Present this menu at the given point under control of the given hand. Allow keyboard input into the menu."
+
+ ^ self popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: Preferences menuKeyboardControl!
Item was added:
+ ----- Method: MenuMorph>>popUpAt:forHand:in:allowKeyboard: (in category 'control') -----
+ popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean
+ "Present this menu at the given point under control of the given
+ hand."
+ | evt |
+ aWorld submorphs
+ select: [:each | (each isKindOf: MenuMorph)
+ and: [each stayUp not]]
+ thenCollect: [:menu | menu delete].
+ self items isEmpty
+ ifTrue: [^ self].
+ MenuIcons decorateMenu: self.
+ (self submorphs
+ select: [:m | m isKindOf: UpdatingMenuItemMorph])
+ do: [:m | m updateContents].
+ "precompute width"
+ self
+ positionAt: aPoint
+ relativeTo: (selectedItem
+ ifNil: [self items first])
+ inWorld: aWorld.
+ aWorld addMorphFront: self.
+ "Acquire focus for valid pop up behavior"
+ hand newMouseFocus: self.
+ aBoolean
+ ifTrue: [hand newKeyboardFocus: self.
+ self showKeyboardHelp].
+ evt := hand lastEvent.
+ (evt isKeyboard
+ or: [evt isMouse
+ and: [evt anyButtonPressed not]])
+ ifTrue: ["Select first item if button not down"
+ self moveSelectionDown: 1 event: evt
+ "Select first item if button not down"].
+ self updateColor.
+ self changed!
Item was added:
+ ----- Method: MenuMorph>>popUpEvent:in: (in category 'control') -----
+ popUpEvent: evt in: aWorld
+ "Present this menu in response to the given event."
+
+ | aHand aPosition |
+ aHand := evt ifNotNil: [evt hand] ifNil: [ActiveHand].
+ aPosition := aHand position truncated.
+ ^ self popUpAt: aPosition forHand: aHand in: aWorld
+ !
Item was added:
+ ----- Method: MenuMorph>>popUpForHand:in: (in category 'control') -----
+ popUpForHand: hand in: aWorld
+ | p |
+ "Present this menu under control of the given hand."
+
+ p := hand position truncated.
+ ^self popUpAt: p forHand: hand in: aWorld
+ !
Item was added:
+ ----- Method: MenuMorph>>popUpInWorld (in category 'control') -----
+ popUpInWorld
+ "Present this menu in the current World"
+
+ ^ self popUpInWorld: self currentWorld!
Item was added:
+ ----- Method: MenuMorph>>popUpInWorld: (in category 'control') -----
+ popUpInWorld: aWorld
+ "Present this menu under control of the given hand."
+ ^self popUpAt: aWorld primaryHand position forHand: aWorld primaryHand in: aWorld
+ !
Item was added:
+ ----- Method: MenuMorph>>popUpNoKeyboard (in category 'control') -----
+ popUpNoKeyboard
+ "Present this menu in the current World, *not* allowing keyboard input into the menu"
+
+ ^ self popUpAt: ActiveHand position forHand: ActiveHand in: ActiveWorld allowKeyboard: false!
Item was added:
+ ----- Method: MenuMorph>>popUpOwner (in category 'accessing') -----
+ popUpOwner
+ "Return the current pop-up owner that is the menu item that automatically initiated the receiver."
+ ^ popUpOwner
+ !
Item was added:
+ ----- Method: MenuMorph>>popUpOwner: (in category 'accessing') -----
+ popUpOwner: aMenuItemMorph
+ "Set the current pop-up owner"
+ popUpOwner := aMenuItemMorph.
+ !
Item was added:
+ ----- Method: MenuMorph>>positionAt:relativeTo:inWorld: (in category 'private') -----
+ positionAt: aPoint relativeTo: aMenuItem inWorld: aWorld
+ "Note: items may not be laid out yet (I found them all to be at 0 at 0),
+ so we have to add up heights of items above the selected item."
+
+ | i yOffset sub delta |
+ self fullBounds. "force layout"
+ i := 0.
+ yOffset := 0.
+ [(sub := self submorphs at: (i := i + 1)) == aMenuItem]
+ whileFalse: [yOffset := yOffset + sub height].
+
+ self position: aPoint - (2 @ (yOffset + 8)).
+
+ "If it doesn't fit, show it to the left, not to the right of the hand."
+ self right > aWorld worldBounds right
+ ifTrue:
+ [self right: aPoint x + 1].
+
+ "Make sure that the menu fits in the world."
+ delta := self bounds amountToTranslateWithin:
+ (aWorld worldBounds withHeight: ((aWorld worldBounds height - 18) max: (ActiveHand position y) + 1)).
+ delta = (0 @ 0) ifFalse: [self position: self position + delta]!
Item was added:
+ ----- Method: MenuMorph>>releasesSelection: (in category 'events') -----
+ releasesSelection: evt
+ " The MenuMorph releases its selection if the selected item releases it.
+ Used in #selectItem:event: "
+
+ self selectedItem ifNil: [ ^true ].
+ evt ifNil: [ ^true ].
+ evt isKeyboard ifTrue: [ ^true ].
+ (self selectedItem containsPoint: evt position) ifTrue: [ ^true ].
+ ^self selectedItem releasesSelection: evt!
Item was added:
+ ----- Method: MenuMorph>>removeMatchString (in category 'keyboard control') -----
+ removeMatchString
+ "Remove the matchString, if any."
+ self setProperty: #matchString toValue: String new.
+ self displayFiltered: nil!
Item was added:
+ ----- Method: MenuMorph>>removeStayUpBox (in category 'menu') -----
+ removeStayUpBox
+ | box |
+ submorphs isEmpty ifTrue: [^self].
+ (submorphs first isAlignmentMorph) ifFalse: [^self].
+ box := submorphs first submorphs last.
+ (box isKindOf: IconicButton)
+ ifTrue:
+ [box
+ labelGraphic: (Form extent: box extent depth: 8);
+ shedSelvedge;
+ borderWidth: 0;
+ lock]!
Item was added:
+ ----- Method: MenuMorph>>removeStayUpItems (in category 'menu') -----
+ removeStayUpItems
+ | stayUpItems |
+ stayUpItems := self items select: [ :item | item isStayUpItem ].
+ stayUpItems do: [ :ea | ea delete ].
+ !
Item was added:
+ ----- Method: MenuMorph>>rootMenu (in category 'accessing') -----
+ rootMenu
+ popUpOwner ifNil: [^ self].
+ popUpOwner owner ifNil: [^ self].
+ ^ popUpOwner owner rootMenu!
Item was added:
+ ----- Method: MenuMorph>>selectCurrentItem: (in category 'keyboard control') -----
+ selectCurrentItem: evt
+ | selectable |
+ selectedItem ifNotNil:
+ [selectedItem hasSubMenu
+ ifTrue: [self selectSubMenu: evt]
+ ifFalse: [selectedItem invokeWithEvent: evt]].
+ (selectable := self items) size = 1
+ ifTrue: [selectable first invokeWithEvent: evt]!
Item was added:
+ ----- Method: MenuMorph>>selectItem:event: (in category 'control') -----
+ selectItem: aMenuItem event: anEvent
+
+ " Change the selected item, but first ask the currently selected item
+ if it want to release it. "
+ (self releasesSelection: anEvent) ifFalse: [ ^self ].
+ selectedItem ifNotNil:[selectedItem deselect: anEvent].
+ selectedItem := aMenuItem.
+ selectedItem ifNotNil:[selectedItem select: anEvent].!
Item was added:
+ ----- Method: MenuMorph>>selectMoreItem: (in category 'keyboard control') -----
+ selectMoreItem: evt
+ | allItems more |
+ allItems := self submorphs select: [:m | m isKindOf: MenuItemMorph].
+ more := allItems detect: [:m | (m contents size >= 4) and: [(m contents first: 4) asString = 'more'.]] ifNone: [^ self flash].
+ self selectItem: more event: evt.
+ selectedItem invokeWithEvent: evt!
Item was added:
+ ----- Method: MenuMorph>>selectedItem (in category 'private') -----
+ selectedItem
+ ^selectedItem!
Item was added:
+ ----- Method: MenuMorph>>setDefaultParameters (in category 'initialization') -----
+ setDefaultParameters
+ "change the receiver's appareance parameters"
+
+ | colorFromMenu worldColor menuColor |
+
+ colorFromMenu := Preferences menuColorFromWorld
+ and: [Display depth > 4
+ and: [(worldColor := self currentWorld color) isColor]].
+
+ menuColor := colorFromMenu
+ ifTrue: [worldColor luminance > 0.7
+ ifTrue: [worldColor mixed: 0.85 with: Color black]
+ ifFalse: [worldColor mixed: 0.4 with: Color white]]
+ ifFalse: [Preferences menuColor].
+
+ self color: menuColor.
+ self borderWidth: Preferences menuBorderWidth.
+
+ Preferences menuAppearance3d ifTrue: [
+ self borderStyle: BorderStyle thinGray.
+ self hasDropShadow: true.
+
+ self useSoftDropShadow
+ ifFalse: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666);
+ shadowOffset: 1 @ 1]
+ ifTrue: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.01);
+ shadowOffset: (10 at 8 corner: 10 at 12) ]
+ ]
+ ifFalse: [
+ | menuBorderColor |
+ menuBorderColor := colorFromMenu
+ ifTrue: [worldColor muchDarker]
+ ifFalse: [Preferences menuBorderColor].
+ self borderColor: menuBorderColor.
+ ].
+
+
+ self layoutInset: 3.
+ !
Item was added:
+ ----- Method: MenuMorph>>setInvokingView: (in category 'menu') -----
+ setInvokingView: invokingView
+ "Re-work every menu item of the form
+ <target> perform: <selector>
+ to the form
+ <target> perform: <selector> orSendTo: <invokingView>.
+ This supports MVC's vectoring of non-model messages to the editPane."
+ self items do:
+ [:item |
+ item hasSubMenu
+ ifTrue: [ item subMenu setInvokingView: invokingView]
+ ifFalse: [ item arguments isEmpty ifTrue: "only the simple messages"
+ [item arguments: (Array with: item selector with: invokingView).
+ item selector: #perform:orSendTo:]]]!
Item was added:
+ ----- Method: MenuMorph>>setTarget: (in category 'menu') -----
+ setTarget: evt
+ "Set the default target object to be used for add item commands, and re-target all existing items to the new target or the the invoking hand."
+
+ | oldDefaultTarget |
+ oldDefaultTarget := defaultTarget .
+ self sightTargets: evt.
+ oldDefaultTarget ~~ defaultTarget
+ ifTrue: [self updateItemsWithTarget: defaultTarget orWithHand: evt hand ].
+ !
Item was added:
+ ----- Method: MenuMorph>>setTitleParametersFor: (in category 'initialization') -----
+ setTitleParametersFor: aMenuTitle
+ | menuTitleColor menuTitleBorderColor |
+ self wantsRoundedCorners
+ ifTrue: [aMenuTitle useRoundedCorners].
+
+ menuTitleColor := Preferences menuColorFromWorld
+ ifTrue: [self color darker]
+ ifFalse: [Preferences menuTitleColor].
+
+ menuTitleBorderColor := Preferences menuAppearance3d
+ ifTrue: [#inset]
+ ifFalse: [Preferences menuColorFromWorld
+ ifTrue: [self color darker muchDarker]
+ ifFalse: [Preferences menuTitleBorderColor]].
+
+ aMenuTitle
+ setColor: menuTitleColor
+ borderWidth: Preferences menuTitleBorderWidth
+ borderColor: menuTitleBorderColor;
+ vResizing: #shrinkWrap;
+ wrapCentering: #center;
+ cellPositioning: #topCenter;
+ layoutInset: 0.
+ !
Item was added:
+ ----- Method: MenuMorph>>showKeyboardHelp (in category 'keystroke helpers') -----
+ showKeyboardHelp
+
+ | help |
+ help := self balloonMorphClass
+ string: 'Enter text to narrow selection\down to matching items ' withCRs
+ for: self
+ corner: #topLeft.
+ help popUpAt: self topCenter forHand: self activeHand!
Item was added:
+ ----- Method: MenuMorph>>stayUp (in category 'accessing') -----
+ stayUp
+
+ ^ stayUp
+ !
Item was added:
+ ----- Method: MenuMorph>>stayUp: (in category 'accessing') -----
+ stayUp: aBoolean
+
+ stayUp := aBoolean.
+ aBoolean ifTrue: [ self removeStayUpBox ].!
Item was added:
+ ----- Method: MenuMorph>>stepIntoSubmenu: (in category 'keystroke helpers') -----
+ stepIntoSubmenu: evt
+
+ (selectedItem notNil and: [ selectedItem hasSubMenu ]) ifTrue: [
+ evt hand newMouseFocus: selectedItem subMenu.
+ evt hand newKeyboardFocus: selectedItem subMenu.
+ selectedItem subMenu moveSelectionDown: 1 event: evt.
+ ^true ].
+ ^false!
Item was added:
+ ----- Method: MenuMorph>>target: (in category 'menu') -----
+ target: aMorph
+ "Set defaultTarget since thats what we got.
+ For the sake of targetSighting which assumes #target is a word we know."
+
+ defaultTarget := aMorph!
Item was added:
+ ----- Method: MenuMorph>>title: (in category 'construction') -----
+ title: aString
+ "Add a title line at the top of this menu."
+
+ self addTitle: aString!
Item was added:
+ ----- Method: MenuMorph>>toggleStayUp: (in category 'menu') -----
+ toggleStayUp: evt
+ "Toggle my 'stayUp' flag and adjust the menu item to reflect its new state."
+
+ self items do: [:item |
+ item isStayUpItem ifTrue:
+ [self stayUp: stayUp not.
+ stayUp
+ ifTrue: [item contents: 'dismiss this menu']
+ ifFalse: [item contents: 'keep this menu up']]].
+ evt hand releaseMouseFocus: self.
+ stayUp ifFalse: [self topRendererOrSelf delete].
+ !
Item was added:
+ ----- Method: MenuMorph>>toggleStayUpIgnore:evt: (in category 'menu') -----
+ toggleStayUpIgnore: ignored evt: evt
+
+ "This variant is resistant to the MVC compatibility in #setInvokingView:"
+
+ self toggleStayUp: evt.
+ !
Item was added:
+ ----- Method: MenuMorph>>undoGrabCommand (in category 'dropping/grabbing') -----
+ undoGrabCommand
+ ^nil!
Item was added:
+ ----- Method: MenuMorph>>unfilterOrEscape: (in category 'keyboard control') -----
+ unfilterOrEscape: evt
+ self valueOfProperty: #matchString
+ ifPresentDo:
+ [:str |
+
+ str isEmpty
+ ifFalse:
+ ["If filtered, first ESC removes filter"
+
+ self setProperty: #matchString toValue: String new.
+ self selectItem: nil event: evt.
+ self displayFiltered: evt]].
+ "If a stand-alone menu, just delete it"
+ popUpOwner ifNil: [^self delete].
+ "If a sub-menu, then deselect, and return focus to outer menu"
+ self selectSuperMenu: evt!
Item was added:
+ ----- Method: MenuMorph>>updateColor (in category 'control') -----
+ updateColor
+ | fill title |
+ self class gradientMenu
+ ifFalse: [^ self].
+ (self fillStyle == self color) not
+ ifTrue: [^ self]. "Don't apply the gradient more than once"
+ ""
+ fill := GradientFillStyle ramp: {0.0 -> Color white. 1 -> self color}.
+ ""
+ fill
+ radial: false;
+ origin: self topLeft;
+ direction: 0 @ self height.
+ ""
+ self fillStyle: fill.
+ "
+ update the title color"
+ title := self allMorphs
+ detect: [:each | each hasProperty: #titleString]
+ ifNone: [^ self].
+ ""
+ fill := GradientFillStyle ramp: {0.0 -> title color twiceLighter. 1 -> title color twiceDarker}.
+ ""
+ fill
+ origin: title topLeft;
+ direction: title width @ 0.
+ ""
+ title fillStyle: fill!
Item was added:
+ ----- Method: MenuMorph>>updateItemsWithTarget:orWithHand: (in category 'menu') -----
+ updateItemsWithTarget: aTarget orWithHand: aHand
+ "re-target all existing items"
+ self items do:
+ [:item | item target ifNotNil: [
+ item target isHandMorph
+ ifTrue: [item target: aHand]
+ ifFalse: [item target: aTarget] ] ]!
Item was added:
+ ----- Method: MenuMorph>>updateMenu (in category 'update') -----
+ updateMenu
+ " Do nothing "!
Item was added:
+ ----- Method: MenuMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals."
+
+ super veryDeepFixupWith: deepCopier.
+ defaultTarget := deepCopier references at: defaultTarget ifAbsent: [defaultTarget].
+ popUpOwner := deepCopier references at: popUpOwner ifAbsent: [popUpOwner].
+ activeSubMenu := deepCopier references at: activeSubMenu ifAbsent:[activeSubMenu].!
Item was added:
+ ----- Method: MenuMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ "defaultTarget := defaultTarget. Weakly copied"
+ selectedItem := selectedItem veryDeepCopyWith: deepCopier.
+ stayUp := stayUp veryDeepCopyWith: deepCopier.
+ popUpOwner := popUpOwner. "Weakly copied"
+ activeSubMenu := activeSubMenu. "Weakly copied"
+ !
Item was added:
+ ----- Method: MenuMorph>>wantsRoundedCorners (in category 'rounding') -----
+ wantsRoundedCorners
+
+ ^ self class roundedMenuCorners or: [super wantsRoundedCorners]!
Item was added:
+ ----- Method: MenuMorph>>wantsToBeDroppedInto: (in category 'control') -----
+ wantsToBeDroppedInto: aMorph
+ "Return true if it's okay to drop the receiver into aMorph. A single-item MenuMorph is in effect a button rather than a menu, and as such should not be reluctant to be dropped into another object."
+
+ ^ (aMorph isWorldMorph or: [submorphs size = 1]) or:
+ [Preferences systemWindowEmbedOK]!
Item was added:
+ Object subclass: #MenuUpdater
+ instanceVariableNames: 'updater updateSelector arguments'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus'!
Item was added:
+ ----- Method: MenuUpdater>>update: (in category 'as yet unclassified') -----
+ update: aMenuMorph
+ "Reconstitute the menu by first removing the contents and then building it afresh"
+
+ aMenuMorph removeAllMorphs.
+ arguments
+ ifNil: [ updater perform: updateSelector with: aMenuMorph ]
+ ifNotNil: [
+ updater
+ perform: updateSelector
+ withArguments: (arguments copyWith: aMenuMorph) ].
+ aMenuMorph changed!
Item was added:
+ ----- Method: MenuUpdater>>updater:updateSelector: (in category 'as yet unclassified') -----
+ updater: anObject updateSelector: aSelector
+
+ self updater: anObject updateSelector: aSelector arguments: nil!
Item was added:
+ ----- Method: MenuUpdater>>updater:updateSelector:arguments: (in category 'as yet unclassified') -----
+ updater: anObject updateSelector: aSelector arguments: anArray
+
+ updater := anObject.
+ updateSelector := aSelector.
+ arguments := anArray!
Item was added:
+ ----- Method: MessageSet>>representsSameBrowseeAs: (in category '*morphic') -----
+ representsSameBrowseeAs: anotherModel
+ ^ self hasUnacceptedEdits not
+ and: [ messageList = anotherModel messageList ]!
Item was added:
+ PolygonMorph subclass: #MixedCurveMorph
+ instanceVariableNames: 'slopeClamps'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic-NewCurve'!
+
+ !MixedCurveMorph commentStamp: '<historical>' prior: 0!
+ A MixedCurveMorph is Curve that can be broken up into separately curved segments. It allows for the creation of matching edges( e. g. for jigsaw puzzle pieces).
+
+ Instance Variables
+ slopeClamps: <Array>
+
+ slopeClamps
+ - elements of array are either 0 or nil. Indicating whether slope for the corresponding vertex is 0 at 0 or unknown and therefore to be calculated. There is one element for each vertex.
+
+
+ !
Item was added:
+ ----- Method: MixedCurveMorph class>>descriptionForPartsBin (in category 'as yet unclassified') -----
+ descriptionForPartsBin
+ ^ self partName: 'Mixed'
+ categories: #('Graphics' 'Basic')
+ documentation: 'A Curve with optional bends and segments. Shift click to get handles.
+ Click handles to change bends. Move handles to move the points.'!
Item was added:
+ ----- Method: MixedCurveMorph>>clamps (in category 'access') -----
+ clamps
+ " Return a collection of clamps the same size as vertices.
+ If necessary default to unclamped slopes.
+ "
+
+ slopeClamps
+ ifNil: [ ^ slopeClamps := Array new: vertices size ] .
+ slopeClamps size = vertices size
+ ifFalse: [ ^ slopeClamps := Array new: vertices size ] .
+ ^ slopeClamps !
Item was added:
+ ----- Method: MixedCurveMorph>>clickVertex:event:fromHandle: (in category 'editing') -----
+ clickVertex: ix event: evt fromHandle: handle
+ " Toggle the state of the clamp. "
+ "Note: self clamps assures slopeClamps will be same size as vertices"
+
+ (self clamps at: ix)
+ ifNil: [ slopeClamps at: ix put: 0 ]
+ ifNotNil: [ slopeClamps at: ix put: nil ] .
+ self setVertices: vertices .
+
+ !
Item was added:
+ ----- Method: MixedCurveMorph>>deleteVertexAt: (in category 'editing') -----
+ deleteVertexAt: anIndex
+ (slopeClamps :=
+ slopeClamps
+ copyReplaceFrom: anIndex
+ to: anIndex
+ with: Array new) .
+ self
+ setVertices: (vertices
+ copyReplaceFrom: anIndex
+ to: anIndex
+ with: Array new).
+ !
Item was added:
+ ----- Method: MixedCurveMorph>>handleColorAt: (in category 'access') -----
+ handleColorAt: vertIndex
+ " clamped handles are cyan and
+ unclamped handles are yellow."
+
+ (self clamps at: vertIndex ) ifNil: [ ^ Color yellow ] .
+ ^ Color cyan
+ !
Item was added:
+ ----- Method: MixedCurveMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ self extent: 32 at 20 .
+
+ self rectOval.
+ self clamps . "This initializes slopeClamps."
+ slopeClamps at: 1 put: 0 .
+ slopeClamps at: 4 put: 0 .
+
+ closed := true.
+ smoothCurve := true.
+ arrows := #none.
+ self computeBounds!
Item was added:
+ ----- Method: MixedCurveMorph>>insertVertexAt:put: (in category 'editing') -----
+ insertVertexAt: anIndex put: aValue
+ "New vertexs are unclamped."
+ "Note: order is important.
+ The clamps array must match vertex size before setVertices: is performed."
+ slopeClamps := slopeClamps
+ copyReplaceFrom: anIndex + 1 to: anIndex with: (Array with: nil).
+ self setVertices: (vertices copyReplaceFrom: anIndex + 1 to: anIndex
+ with: (Array with: aValue)).!
Item was added:
+ ----- Method: MixedCurveMorph>>slopes: (in category 'smoothing') -----
+ slopes: knots
+ "Choose slopes according to state of polygon and preferences"
+ self isCurvy
+ ifFalse: [^ knots segmentedSlopes].
+ ^ (closed
+ and: [self isCurvier])
+ ifTrue: [ knots closedCubicSlopes: self clamps ]
+ ifFalse: [knots naturalCubicSlopes: self clamps ]!
Item was added:
+ ----- Method: Model>>postAcceptBrowseFor: (in category '*morphic') -----
+ postAcceptBrowseFor: anotherModel
+ "If I am taking over browsing for anotherModel, sucblasses may override to, for example, position me to the object to be focused on."!
Item was added:
+ ----- Method: Model>>representsSameBrowseeAs: (in category '*morphic') -----
+ representsSameBrowseeAs: anotherModel
+ "Answer true if my browser can browse what anotherModel wants to browse."
+ ^ false!
Item was added:
+ ----- Method: Model>>step (in category '*morphic') -----
+ step
+ "Default for morphic models is no-op"!
Item was added:
+ Object subclass: #Morph
+ instanceVariableNames: 'bounds owner submorphs fullBounds color extension'
+ classVariableNames: 'IndicateKeyboardFocus PreferredCornerRadius UseSoftDropShadow'
+ poolDictionaries: ''
+ category: 'Morphic-Kernel'!
+
+ !Morph commentStamp: 'efc 2/26/2003 20:01' prior: 0!
+ A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://minnow.cc.gatech.edu/squeak/30.
+
+ Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, set its #visible property to false using the #visible: method.
+
+ The World (screen) coordinate system is used for most coordinates, but can be changed if there is a TransformMorph somewhere in the owner chain.
+
+ My instance variables have accessor methods (e.g., #bounds, #bounds:). Most users should use the accessor methods instead of using the instance variables directly.
+
+ Structure:
+ instance var Type Description
+ bounds Rectangle A Rectangle indicating my position and a size that will enclose me.
+ owner Morph My parent Morph, or nil for the top-level Morph, which is a
+ or nil world, typically a PasteUpMorph.
+ submorphs Array My child Morphs.
+ fullBounds Rectangle A Rectangle minimally enclosing me and my submorphs.
+ color Color My primary color. Subclasses can use this in different ways.
+ extension MorphExtension Allows extra properties to be stored without adding a
+ or nil storage burden to all morphs.
+
+ By default, Morphs do not position their submorphs. Morphs may position their submorphs directly or use a LayoutPolicy to automatically control their submorph positioning.
+
+ Although Morph has some support for BorderStyle, most users should use BorderedMorph if they want borders.!
Item was added:
+ ----- Method: Morph class>>allSketchMorphClasses (in category 'testing') -----
+ allSketchMorphClasses
+ "Morph allSketchMorphClasses"
+ ^ Array
+ streamContents: [:s | self
+ withAllSubclassesDo: [:cls | cls isSketchMorphClass
+ ifTrue: [s nextPut: cls ]]]
+ !
Item was added:
+ ----- Method: Morph class>>allSketchMorphForms (in category 'testing') -----
+ allSketchMorphForms
+ "Answer a Set of forms of SketchMorph (sub) instances, except those
+ used as button images, ones being edited, and those with 0 extent."
+
+ | reasonableForms |
+ reasonableForms := Set new.
+ Morph allSketchMorphClasses do:
+ [:cls | cls allInstances do:
+ [:m | | form |
+ (m owner isKindOf: SketchEditorMorph orOf: IconicButton)
+ ifFalse:
+ [form := m form.
+ ((form width > 0) and: [form height > 0]) ifTrue: [reasonableForms add: form]]]].
+ ^ reasonableForms!
Item was added:
+ ----- Method: Morph class>>authoringPrototype (in category 'scripting') -----
+ authoringPrototype
+ "Answer an instance of the receiver suitable for placing in a parts bin for authors"
+
+ ^ self new markAsPartsDonor!
Item was added:
+ ----- Method: Morph class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') -----
+ fileReaderServicesForFile: fullName suffix: suffix
+
+ ^({ 'morph'. 'morphs'. 'sp'. '*' } includes: suffix)
+ ifTrue: [
+ {SimpleServiceEntry
+ provider: self
+ label: 'load as morph'
+ selector: #fromFileName:
+ description: 'load as morph'}]
+ ifFalse: [#()]!
Item was added:
+ ----- Method: Morph class>>fromFileName: (in category 'fileIn/Out') -----
+ fromFileName: fullName
+ "Reconstitute a Morph from the file, presumed to be represent a Morph saved
+ via the SmartRefStream mechanism, and open it in an appropriate Morphic world"
+
+ | aFileStream morphOrList |
+ aFileStream := (MultiByteBinaryOrTextStream with: ((FileStream readOnlyFileNamed: fullName) binary contentsOfEntireFile)) binary reset.
+ morphOrList := aFileStream fileInObjectAndCode.
+ (morphOrList isKindOf: SqueakPage) ifTrue: [morphOrList := morphOrList contentsMorph].
+ Smalltalk isMorphic
+ ifTrue: [ActiveWorld addMorphsAndModel: morphOrList]
+ ifFalse:
+ [morphOrList isMorph ifFalse: [self inform: 'Can only load a single morph
+ into an mvc project via this mechanism.'].
+ morphOrList openInWorld]!
Item was added:
+ ----- Method: Morph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ "Return true for all classes that can be instantiated from the menu"
+ ^ true!
Item was added:
+ ----- Method: Morph class>>indicateKeyboardFocus (in category 'preferences') -----
+ indicateKeyboardFocus
+
+ <preference: 'Indicate Keyboard Focus'
+ categoryList: #(keyboard Morphic general)
+ description: 'If enabled, there will be a visual highlight drawn onto the morph to help the user find out about the current keyboard focus. This is especially useful when the keyboard focus does not match the mouse position.'
+ type: #Boolean>
+ ^ IndicateKeyboardFocus ifNil: [false]!
Item was added:
+ ----- Method: Morph class>>indicateKeyboardFocus: (in category 'preferences') -----
+ indicateKeyboardFocus: aBoolean
+
+ IndicateKeyboardFocus := aBoolean.!
Item was added:
+ ----- Method: Morph class>>initialize (in category 'class initialization') -----
+ initialize
+ "Morph initialize"
+ FileList registerFileReader: self!
Item was added:
+ ----- Method: Morph class>>initializedInstance (in category 'instance creation') -----
+ initializedInstance
+ "Answer an instance of the receiver which in some sense is initialized. In the case of Morphs, this will yield an instance that can be attached to the Hand after having received the same kind of basic initialization that would be obtained from an instance chosen from the 'new morph' menu.
+ Return nil if the receiver is reluctant for some reason to return such a thing"
+
+ ^ (self class includesSelector: #descriptionForPartsBin)
+ ifTrue:
+ [self newStandAlone]
+ ifFalse:
+ [self new]!
Item was added:
+ ----- Method: Morph class>>isSketchMorphClass (in category 'testing') -----
+ isSketchMorphClass
+ ^false!
Item was added:
+ ----- Method: Morph class>>morphsUnknownToTheirOwners (in category 'misc') -----
+ morphsUnknownToTheirOwners
+ "Return a list of all morphs (other than HandMorphs) whose owners do not contain them in their submorph lists"
+ "Morph morphsUnknownToTheirOwners"
+ | problemMorphs |
+ problemMorphs := OrderedCollection new.
+ self allSubInstances do:
+ [:m | | itsOwner |
+ (m isHandMorph not and: [((itsOwner := m owner) ~~ nil and: [(itsOwner submorphs includes: m) not])])
+ ifTrue:
+ [problemMorphs add: m]].
+ ^ problemMorphs!
Item was added:
+ ----- Method: Morph class>>newBounds: (in category 'instance creation') -----
+ newBounds: bounds
+
+ ^ self new privateBounds: bounds!
Item was added:
+ ----- Method: Morph class>>newBounds:color: (in category 'instance creation') -----
+ newBounds: bounds color: color
+
+ ^ (self new privateBounds: bounds) privateColor: color
+ !
Item was added:
+ ----- Method: Morph class>>newStandAlone (in category 'new-morph participation') -----
+ newStandAlone
+ "Answer an instance capable of standing by itself as a usable morph."
+
+ ^ self basicNew initializeToStandAlone!
Item was added:
+ ----- Method: Morph class>>newSticky (in category 'instance creation') -----
+ newSticky
+
+ ^ self new beSticky!
Item was added:
+ ----- Method: Morph class>>partName:categories:documentation: (in category 'new-morph participation') -----
+ partName: aName categories: aList documentation: aDoc
+ "Answer a DescriptionForPartsBin which will represent a launch of a new instance of my class via the #newStandAlone protocol sent to my class. Use the category-list and documentation provided"
+
+
+ ^ DescriptionForPartsBin new
+ formalName: aName
+ categoryList: aList
+ documentation: aDoc
+ globalReceiverSymbol: self name
+ nativitySelector: #newStandAlone!
Item was added:
+ ----- Method: Morph class>>partName:categories:documentation:sampleImageForm: (in category 'new-morph participation') -----
+ partName: aName categories: aList documentation: aDoc sampleImageForm: aForm
+ "Answer a DescriptionForPartsBin which will represent a launch of a new instance of my class via the #newStandAlone protocol sent to my class. Use the category-list and documentation provided. This variant allows an overriding image form to be provided, useful in cases where we don't want to launch a sample instance just to get the form"
+
+ | descr |
+ descr := DescriptionForPartsBin new
+ formalName: aName
+ categoryList: aList
+ documentation: aDoc
+ globalReceiverSymbol: self name
+ nativitySelector: #newStandAlone.
+ descr sampleImageForm: aForm.
+ ^ descr
+ !
Item was added:
+ ----- Method: Morph class>>preferredCornerRadius (in category 'preferences') -----
+ preferredCornerRadius
+
+ <preference: 'Preferred Corner Radius'
+ categoryList: #(Morphic windows menus)
+ description: 'If a morph wants rounded corners, use this radius. May be overwritten in subclasses.'
+ type: #Number>
+ ^ PreferredCornerRadius ifNil: [6]!
Item was added:
+ ----- Method: Morph class>>preferredCornerRadius: (in category 'preferences') -----
+ preferredCornerRadius: anInteger
+
+ PreferredCornerRadius := anInteger.!
Item was added:
+ ----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') -----
+ serviceLoadMorphFromFile
+ "Answer a service for loading a .morph file"
+
+ ^ SimpleServiceEntry
+ provider: self
+ label: 'load as morph'
+ selector: #fromFileName:
+ description: 'load as morph'
+ buttonLabel: 'load'!
Item was added:
+ ----- Method: Morph class>>services (in category 'fileIn/Out') -----
+ services
+
+ ^ Array with: self serviceLoadMorphFromFile!
Item was added:
+ ----- Method: Morph class>>unload (in category 'initialize-release') -----
+ unload
+
+ FileList unregisterFileReader: self !
Item was added:
+ ----- Method: Morph class>>useSoftDropShadow (in category 'preferences') -----
+ useSoftDropShadow
+
+ <preference: 'Use Soft Drop Shadow'
+ categoryList: #(Morphic windows menus performance)
+ description: 'If drop shadows are enabled, this preference will switch between hard and soft shadows. Soft shadows are more expensive.'
+ type: #Boolean>
+ ^ UseSoftDropShadow ifNil: [ false ]!
Item was added:
+ ----- Method: Morph class>>useSoftDropShadow: (in category 'preferences') -----
+ useSoftDropShadow: aBoolean
+
+ UseSoftDropShadow = aBoolean ifTrue: [^ self].
+ UseSoftDropShadow := aBoolean.
+
+ SystemWindow refreshAllWindows.
+ SystemProgressMorph reset.
+ TheWorldMainDockingBar updateInstances.!
Item was added:
+ ----- Method: Morph>>abandon (in category 'submorphs-add/remove') -----
+ abandon
+ "Like delete, but we really intend not to use this morph again. Clean up a few things."
+
+ self delete!
Item was added:
+ ----- Method: Morph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
+ aboutToBeGrabbedBy: aHand
+ "The receiver is being grabbed by a hand.
+ Perform necessary adjustments (if any) and return the actual morph
+ that should be added to the hand."
+ | extentToHandToHand cmd |
+ self formerOwner: owner.
+ self formerPosition: self position.
+ cmd := self undoGrabCommand.
+ cmd ifNotNil:[self setProperty: #undoGrabCommand toValue: cmd].
+ (extentToHandToHand := self valueOfProperty: #expandedExtent)
+ ifNotNil:
+ [self removeProperty: #expandedExtent.
+ self extent: extentToHandToHand].
+ ^self "Grab me"!
Item was added:
+ ----- Method: Morph>>absorbStateFromRenderer: (in category 'menus') -----
+ absorbStateFromRenderer: aRenderer
+ "Transfer knownName, actorState, visible, and player info over from aRenderer, which was formerly imposed above me as a transformation shell but is now going away."
+
+ | current |
+ (current := aRenderer actorStateOrNil) ifNotNil:
+ [self actorState: current.
+ aRenderer actorState: nil].
+
+ (current := aRenderer knownName) ifNotNil:
+ [self setNameTo: current.
+ aRenderer setNameTo: nil].
+
+ (current := aRenderer player) ifNotNil:
+ [self player: current.
+ current rawCostume: self.
+ aRenderer player: nil].
+
+ self visible: aRenderer visible!
Item was added:
+ ----- Method: Morph>>acceptDroppingMorph:event: (in category 'layout') -----
+ acceptDroppingMorph: aMorph event: evt
+ "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. This default implementation just adds the given morph to the receiver."
+ | layout |
+ layout := self layoutPolicy.
+ layout ifNil:[^self addMorph: aMorph].
+ self privateAddMorph: aMorph
+ atIndex: (layout indexForInserting: aMorph at: evt position in: self).!
Item was added:
+ ----- Method: Morph>>actWhen (in category 'submorphs-add/remove') -----
+ actWhen
+ "Answer when the receiver, probably being used as a button, should have its action triggered"
+
+ ^ self valueOfProperty: #actWhen ifAbsentPut: [#buttonDown]!
Item was added:
+ ----- Method: Morph>>actWhen: (in category 'submorphs-add/remove') -----
+ actWhen: aButtonPhase
+ "Set the receiver's actWhen trait"
+
+ self setProperty: #actWhen toValue: aButtonPhase!
Item was added:
+ ----- Method: Morph>>actionMap (in category 'events-accessing') -----
+ actionMap
+ "Answer an action map"
+
+ | actionMap |
+ actionMap := self valueOfProperty: #actionMap.
+ actionMap ifNil:
+ [actionMap := self createActionMap].
+ ^ actionMap!
Item was added:
+ ----- Method: Morph>>activeHand (in category 'structure') -----
+ activeHand
+ ^ActiveHand!
Item was added:
+ ----- Method: Morph>>actorState: (in category 'accessing') -----
+ actorState: anActorState
+ "change the receiver's actorState"
+ self assureExtension actorState: anActorState!
Item was added:
+ ----- Method: Morph>>actorStateOrNil (in category 'accessing') -----
+ actorStateOrNil
+ "answer the redeiver's actorState"
+ ^ extension ifNotNil: [extension actorState]!
Item was added:
+ ----- Method: Morph>>adaptToWorld: (in category 'e-toy support') -----
+ adaptToWorld: aWorld
+ "The receiver finds itself operating in a possibly-different new world. If any of the receiver's parts are world-dependent (such as a target of a SimpleButtonMorph, etc.), then have them adapt accordingly"
+ submorphs do: [:m | m adaptToWorld: aWorld].
+ self eventHandler ifNotNil:
+ [self eventHandler adaptToWorld: aWorld]!
Item was added:
+ ----- Method: Morph>>addAddHandMenuItemsForHalo:hand: (in category 'menus') -----
+ addAddHandMenuItemsForHalo: aMenu hand: aHandMorph
+ "The former charter of this method was to add halo menu items that pertained specifically to the hand. Over time this charter has withered, and most morphs reimplement this method simply to add their morph-specific menu items. So in the latest round, all other implementors in the standard image have been removed. However, this is left here as a hook for the benefit of existing code in client uses."
+
+ !
Item was added:
+ ----- Method: Morph>>addAlarm:after: (in category 'events-alarms') -----
+ addAlarm: aSelector after: delayTime
+ "Add an alarm (that is an action to be executed once) with the given set of parameters"
+ ^self addAlarm: aSelector withArguments: #() after: delayTime!
Item was added:
+ ----- Method: Morph>>addAlarm:at: (in category 'events-alarms') -----
+ addAlarm: aSelector at: scheduledTime
+ "Add an alarm (that is an action to be executed once) with the given set of parameters"
+ ^self addAlarm: aSelector withArguments: #() at: scheduledTime!
Item was added:
+ ----- Method: Morph>>addAlarm:with:after: (in category 'events-alarms') -----
+ addAlarm: aSelector with: arg1 after: delayTime
+ "Add an alarm (that is an action to be executed once) with the given set of parameters"
+ ^self addAlarm: aSelector withArguments: (Array with: arg1) after: delayTime!
Item was added:
+ ----- Method: Morph>>addAlarm:with:at: (in category 'events-alarms') -----
+ addAlarm: aSelector with: arg1 at: scheduledTime
+ "Add an alarm (that is an action to be executed once) with the given set of parameters"
+ ^self addAlarm: aSelector withArguments: (Array with: arg1) at: scheduledTime!
Item was added:
+ ----- Method: Morph>>addAlarm:with:with:after: (in category 'events-alarms') -----
+ addAlarm: aSelector with: arg1 with: arg2 after: delayTime
+ "Add an alarm (that is an action to be executed once) with the given set of parameters"
+ ^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) after: delayTime!
Item was added:
+ ----- Method: Morph>>addAlarm:with:with:at: (in category 'events-alarms') -----
+ addAlarm: aSelector with: arg1 with: arg2 at: scheduledTime
+ "Add an alarm (that is an action to be executed once) with the given set of parameters"
+ ^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) at: scheduledTime!
Item was added:
+ ----- Method: Morph>>addAlarm:withArguments:after: (in category 'events-alarms') -----
+ addAlarm: aSelector withArguments: args after: delayTime
+ "Add an alarm (that is an action to be executed once) with the given set of parameters"
+ ^self addAlarm: aSelector withArguments: args at: Time millisecondClockValue + delayTime!
Item was added:
+ ----- Method: Morph>>addAlarm:withArguments:at: (in category 'events-alarms') -----
+ addAlarm: aSelector withArguments: args at: scheduledTime
+ "Add an alarm (that is an action to be executed once) with the given set of parameters"
+ | scheduler |
+ scheduler := self alarmScheduler.
+ scheduler ifNotNil:[scheduler addAlarm: aSelector withArguments: args for: self at: scheduledTime].!
Item was added:
+ ----- Method: Morph>>addAllMorphs: (in category 'submorphs-add/remove') -----
+ addAllMorphs: aCollection
+ ^self addAllMorphsBack: aCollection!
Item was added:
+ ----- Method: Morph>>addAllMorphs:after: (in category 'submorphs-add/remove') -----
+ addAllMorphs: aCollection after: anotherMorph
+ ^self addAllMorphs: aCollection behind: anotherMorph!
Item was added:
+ ----- Method: Morph>>addAllMorphs:behind: (in category 'submorphs-add/remove') -----
+ addAllMorphs: aCollection behind: anotherMorph
+ ^self privateAddAllMorphs: aCollection
+ atIndex: (submorphs indexOf: anotherMorph) + 1!
Item was added:
+ ----- Method: Morph>>addAllMorphs:inFrontOf: (in category 'submorphs-add/remove') -----
+ addAllMorphs: aCollection inFrontOf: anotherMorph
+ ^self privateAddAllMorphs: aCollection
+ atIndex: ((submorphs indexOf: anotherMorph) max: 1)!
Item was added:
+ ----- Method: Morph>>addAllMorphsBack: (in category 'submorphs-add/remove') -----
+ addAllMorphsBack: aCollection
+ ^self privateAddAllMorphs: aCollection atIndex: submorphs size + 1!
Item was added:
+ ----- Method: Morph>>addAllMorphsFront: (in category 'submorphs-add/remove') -----
+ addAllMorphsFront: aCollection
+ ^self privateAddAllMorphs: aCollection atIndex: 1!
Item was added:
+ ----- Method: Morph>>addBorderStyleMenuItems:hand: (in category 'menu') -----
+ addBorderStyleMenuItems: aMenu hand: aHandMorph
+ "Probably one could offer border-style items even if it's not a borderedMorph, so this remains a loose end for the moment"
+ !
Item was added:
+ ----- Method: Morph>>addCellLayoutMenuItems:hand: (in category 'layout-menu') -----
+ addCellLayoutMenuItems: aMenu hand: aHand
+ "Cell (e.g., child) related items"
+ | menu sub |
+ menu := MenuMorph new defaultTarget: self.
+ menu addUpdating: #hasDisableTableLayoutString action: #changeDisableTableLayout.
+ menu addLine.
+
+ sub := MenuMorph new defaultTarget: self.
+ #(rigid shrinkWrap spaceFill) do:[:sym|
+ sub addUpdating: #hResizingString: target: self selector: #hResizing: argumentList: (Array with: sym)].
+ menu add:'horizontal resizing' translated subMenu: sub.
+
+ sub := MenuMorph new defaultTarget: self.
+ #(rigid shrinkWrap spaceFill) do:[:sym|
+ sub addUpdating: #vResizingString: target: self selector: #vResizing: argumentList: (Array with: sym)].
+ menu add:'vertical resizing' translated subMenu: sub.
+
+ aMenu ifNotNil:[aMenu add: 'child layout' translated subMenu: menu].
+ ^menu!
Item was added:
+ ----- Method: Morph>>addCopyItemsTo: (in category 'menus') -----
+ addCopyItemsTo: aMenu
+ "Add copy-like items to the halo menu"
+
+ | subMenu |
+ subMenu := MenuMorph new defaultTarget: self.
+ subMenu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:.
+ subMenu add: 'copy text' translated action: #clipText.
+ subMenu add: 'copy Postscript' translated action: #clipPostscript.
+ subMenu add: 'print Postscript to file...' translated target: self selector: #printPSToFile.
+ aMenu add: 'copy & print...' translated subMenu: subMenu!
Item was added:
+ ----- Method: Morph>>addCustomHaloMenuItems:hand: (in category 'menus') -----
+ addCustomHaloMenuItems: aMenu hand: aHandMorph
+ "Add morph-specific items to the given menu which was invoked by the given hand from the halo. To get started, we defer to the counterpart method used with the option-menu, but in time we can have separate menu choices for halo-menus and for option-menus"
+
+ self addCustomMenuItems: aMenu hand: aHandMorph!
Item was added:
+ ----- Method: Morph>>addCustomMenuItems:hand: (in category 'menus') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ "Add morph-specific items to the given menu which was invoked by the given hand. This method provides is invoked both from the halo-menu and from the control-menu regimes."
+ !
Item was added:
+ ----- Method: Morph>>addDebuggingItemsTo:hand: (in category 'debug and other') -----
+ addDebuggingItemsTo: aMenu hand: aHandMorph
+ aMenu add: 'debug...' translated subMenu: (self buildDebugMenu: aHandMorph)!
Item was added:
+ ----- Method: Morph>>addDropShadow (in category 'drop shadows') -----
+ addDropShadow
+
+ self hasDropShadow: true.
+
+ self useSoftDropShadow
+ ifFalse: [
+ self
+ shadowOffset: 3 at 3;
+ shadowColor: (Color black alpha: 0.5)]
+ ifTrue: [
+ self
+ shadowOffset: (10 at 8 corner: 10 at 12);
+ shadowColor: (Color black alpha: 0.01)].!
Item was added:
+ ----- Method: Morph>>addDropShadowMenuItems:hand: (in category 'drop shadows') -----
+ addDropShadowMenuItems: aMenu hand: aHand
+ | menu |
+ menu := MenuMorph new defaultTarget: self.
+ menu
+ addUpdating: #hasDropShadowString
+ action: #toggleDropShadow.
+ menu addLine.
+ menu add: 'shadow color...' translated target: self selector: #changeShadowColor.
+ menu add: 'shadow offset...' translated target: self selector: #setShadowOffset:.
+ aMenu add: 'drop shadow' translated subMenu: menu.!
Item was added:
+ ----- Method: Morph>>addEmbeddingMenuItemsTo:hand: (in category 'meta-actions') -----
+ addEmbeddingMenuItemsTo: aMenu hand: aHandMorph
+ "Construct a menu offerring embed targets for the receiver. If the incoming menu is is not degenerate, add the constructed menu as a submenu; in any case, answer the embed-target menu"
+
+ | menu potentialEmbeddingTargets |
+
+ potentialEmbeddingTargets := self potentialEmbeddingTargets.
+ potentialEmbeddingTargets size > 1 ifFalse:[^ self].
+
+ menu := MenuMorph new defaultTarget: self.
+
+ potentialEmbeddingTargets reverseDo: [:m |
+ menu
+ add: (m knownName ifNil:[m class name asString])
+ target: m
+ selector: #addMorphFrontFromWorldPosition:
+ argument: self topRendererOrSelf.
+
+ menu lastItem icon: (m iconOrThumbnailOfSize: 16).
+
+ self owner == m ifTrue:[menu lastItem emphasis: 1].
+ ].
+
+ aMenu add:'embed into' translated subMenu: menu.
+
+ ^ menu!
Item was added:
+ ----- Method: Morph>>addExportMenuItems:hand: (in category 'menus') -----
+ addExportMenuItems: aMenu hand: aHandMorph
+ "Add export items to the menu"
+
+ aMenu ifNotNil:
+ [ | aSubMenu |
+ aSubMenu := MenuMorph new defaultTarget: self.
+ aSubMenu add: 'BMP file' translated action: #exportAsBMP.
+ aSubMenu add: 'GIF file' translated action: #exportAsGIF.
+ aSubMenu add: 'JPEG file' translated action: #exportAsJPEG.
+ aSubMenu add: 'PNG file' translated action: #exportAsPNG.
+ aMenu add: 'export...' translated subMenu: aSubMenu]
+ !
Item was added:
+ ----- Method: Morph>>addFillStyleMenuItems:hand: (in category 'menus') -----
+ addFillStyleMenuItems: aMenu hand: aHand
+ "Add the items for changing the current fill style of the Morph"
+ | menu |
+ self canHaveFillStyles ifFalse:[^aMenu add: 'change color...' translated target: self action: #changeColor].
+ menu := MenuMorph new defaultTarget: self.
+ self fillStyle addFillStyleMenuItems: menu hand: aHand from: self.
+ menu addLine.
+ menu add: 'solid fill' translated action: #useSolidFill.
+ menu add: 'gradient fill' translated action: #useGradientFill.
+ menu add: 'bitmap fill' translated action: #useBitmapFill.
+ menu add: 'default fill' translated action: #useDefaultFill.
+ aMenu add: 'fill style' translated subMenu: menu.
+ "aMenu add: 'change color...' translated action: #changeColor"!
Item was added:
+ ----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') -----
+ addFlexShell
+ "Wrap a rotating and scaling shell around this morph."
+
+ | oldHalo flexMorph myWorld anIndex |
+
+ myWorld := self world.
+ oldHalo := self halo.
+ anIndex := self owner submorphIndexOf: self.
+ self owner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self)
+ asElementNumber: anIndex.
+ self transferStateToRenderer: flexMorph.
+ oldHalo ifNotNil: [oldHalo setTarget: flexMorph].
+ myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: flexMorph].
+
+ ^ flexMorph!
Item was added:
+ ----- Method: Morph>>addFlexShellIfNecessary (in category 'rotate scale and flex') -----
+ addFlexShellIfNecessary
+ "If this morph requires a flex shell to scale or rotate,
+ then wrap it in one and return it.
+ Polygons, eg, may override to return themselves."
+
+ ^ self addFlexShell!
Item was added:
+ ----- Method: Morph>>addGestureMenuItems:hand: (in category 'menu') -----
+ addGestureMenuItems: aMenu hand: aHandMorph
+ "If the receiver wishes the Genie menu items, add a line to the menu and then those Genie items, else do nothing"!
Item was added:
+ ----- Method: Morph>>addGraphModelYellowButtonItemsTo:event: (in category 'menu') -----
+ addGraphModelYellowButtonItemsTo: aCustomMenu event: evt
+ ^aCustomMenu!
Item was added:
+ ----- Method: Morph>>addHalo (in category 'halos and balloon help') -----
+ addHalo
+ "Invoke a halo programatically (e.g., not from a meta gesture)"
+ ^self addHalo: nil!
Item was added:
+ ----- Method: Morph>>addHalo: (in category 'halos and balloon help') -----
+ addHalo: evt
+ | halo prospectiveHaloClass |
+ prospectiveHaloClass := Smalltalk at: self haloClass ifAbsent: [HaloMorph].
+ halo := prospectiveHaloClass new bounds: self worldBoundsForHalo.
+ halo popUpFor: self event: evt.
+ ^halo!
Item was added:
+ ----- Method: Morph>>addHalo:from: (in category 'halos and balloon help') -----
+ addHalo: evt from: formerHaloOwner
+ "Transfer a halo from the former halo owner to the receiver"
+ ^self addHalo: evt!
Item was added:
+ ----- Method: Morph>>addHaloActionsTo: (in category 'menus') -----
+ addHaloActionsTo: aMenu
+ "Add items to aMenu representing actions requestable via halo"
+
+ | subMenu |
+ subMenu := MenuMorph new defaultTarget: self.
+ subMenu addTitle: self externalName.
+ subMenu addStayUpItemSpecial.
+ subMenu addLine.
+ subMenu add: 'delete' translated action: #dismissViaHalo.
+ subMenu balloonTextForLastItem: 'Delete this object -- warning -- can be destructive!!' translated.
+
+ self maybeAddCollapseItemTo: subMenu.
+ subMenu add: 'grab' translated action: #openInHand.
+ subMenu balloonTextForLastItem: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' translated.
+
+ subMenu addLine.
+
+ subMenu add: 'resize' translated action: #resizeFromMenu.
+ subMenu balloonTextForLastItem: 'Change the size of this object' translated.
+
+ subMenu add: 'duplicate' translated action: #maybeDuplicateMorph.
+ subMenu balloonTextForLastItem: 'Hand me a copy of this object' translated.
+ "Note that this allows access to the non-instancing duplicate even when this is a uniclass instance"
+
+ self couldMakeSibling ifTrue:
+ [subMenu add: 'make a sibling' translated action: #handUserASibling.
+ subMenu balloonTextForLastItem: 'Make a new sibling of this object and hand it to me' translated].
+
+ subMenu addLine.
+ subMenu add: 'property sheet' translated target: self renderedMorph action: #openAPropertySheet.
+ subMenu balloonTextForLastItem: 'Open a property sheet for me. Allows changing lots of stuff at once.' translated.
+
+ subMenu add: 'set color' translated target: self renderedMorph action: #changeColor.
+ subMenu balloonTextForLastItem: 'Change the color of this object' translated.
+
+ subMenu add: 'viewer' translated target: self action: #beViewed.
+ subMenu balloonTextForLastItem: 'Open a Viewer that will allow everything about this object to be seen and controlled.' translated.
+
+ subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.
+
+ subMenu add: 'hand me a tile' translated target: self action: #tearOffTile.
+ subMenu balloonTextForLastItem: 'Hand me a tile represting this object' translated.
+ subMenu addLine.
+
+ subMenu add: 'inspect' translated target: self action: #inspect.
+ subMenu balloonTextForLastItem: 'Open an Inspector on this object' translated.
+
+ aMenu add: 'halo actions...' translated subMenu: subMenu
+ !
Item was added:
+ ----- Method: Morph>>addHandlesTo:box: (in category 'halos and balloon help') -----
+ addHandlesTo: aHaloMorph box: box
+ "Add halo handles to the halo. Apply the halo filter if appropriate"
+
+
+ aHaloMorph haloBox: box.
+ Preferences haloSpecifications do:
+ [:aSpec | | wantsIt aSelector |
+ aSelector := aSpec addHandleSelector.
+ wantsIt := Preferences selectiveHalos
+ ifTrue:
+ [self wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph]
+ ifFalse:
+ [true].
+ wantsIt ifTrue:
+ [(#(addMakeSiblingHandle: addDupHandle:) includes: aSelector) ifTrue:
+ [wantsIt := self preferredDuplicationHandleSelector = aSelector].
+ wantsIt ifTrue:
+ [aHaloMorph perform: aSelector with: aSpec]]].
+
+ aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box!
Item was added:
+ ----- Method: Morph>>addLayoutMenuItems:hand: (in category 'layout-menu') -----
+ addLayoutMenuItems: topMenu hand: aHand
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu addUpdating: #hasNoLayoutString action: #changeNoLayout.
+ aMenu addUpdating: #hasProportionalLayoutString action: #changeProportionalLayout.
+ aMenu addUpdating: #hasTableLayoutString action: #changeTableLayout.
+ aMenu addLine.
+ aMenu add: 'change layout inset...' translated action: #changeLayoutInset:.
+ aMenu addLine.
+ self addCellLayoutMenuItems: aMenu hand: aHand.
+ self addTableLayoutMenuItems: aMenu hand: aHand.
+ topMenu ifNotNil:[topMenu add: 'layout' translated subMenu: aMenu].
+ ^aMenu!
Item was added:
+ ----- Method: Morph>>addMagicHaloFor: (in category 'halos and balloon help') -----
+ addMagicHaloFor: aHand
+ | halo prospectiveHaloClass |
+ aHand halo ifNotNil:[
+ aHand halo target == self ifTrue:[^self].
+ aHand halo isMagicHalo ifFalse:[^self]].
+ prospectiveHaloClass := Smalltalk at: self haloClass ifAbsent: [HaloMorph].
+ halo := prospectiveHaloClass new bounds: self worldBoundsForHalo.
+ halo popUpMagicallyFor: self hand: aHand.!
Item was added:
+ ----- Method: Morph>>addMiscExtrasTo: (in category 'menus') -----
+ addMiscExtrasTo: aMenu
+ "Add a submenu of miscellaneous extra items to the menu."
+
+ | realOwner realMorph subMenu |
+ subMenu := MenuMorph new defaultTarget: self.
+ (self isWorldMorph not and: [(self renderedMorph isSystemWindow) not])
+ ifTrue: [subMenu add: 'put in a window' translated action: #embedInWindow].
+
+ self isWorldMorph ifFalse:
+ [subMenu add: 'adhere to edge...' translated action: #adhereToEdge.
+ subMenu addLine].
+
+ realOwner := (realMorph := self topRendererOrSelf) owner.
+ (realOwner isKindOf: TextPlusPasteUpMorph) ifTrue:
+ [subMenu add: 'GeeMail stuff...' translated subMenu: (realOwner textPlusMenuFor: realMorph)].
+
+ subMenu
+ add: 'add mouse up action' translated action: #addMouseUpAction;
+ add: 'remove mouse up action' translated action: #removeMouseUpAction;
+ add: 'hand me tiles to fire this button' translated action: #handMeTilesToFire.
+ subMenu addLine.
+ subMenu add: 'arrowheads on pen trails...' translated action: #setArrowheads.
+ subMenu addLine.
+
+ subMenu defaultTarget: self topRendererOrSelf.
+ subMenu add: 'draw new path' translated action: #definePath.
+ subMenu add: 'follow existing path' translated action: #followPath.
+ subMenu add: 'delete existing path' translated action: #deletePath.
+ subMenu addLine.
+
+ self addGestureMenuItems: subMenu hand: ActiveHand.
+
+ aMenu add: 'extras...' translated subMenu: subMenu!
Item was added:
+ ----- Method: Morph>>addModelYellowButtonItemsTo:event: (in category 'menu') -----
+ addModelYellowButtonItemsTo: aCustomMenu event: evt
+ "Give my models a chance to add their context-menu items to
+ aCustomMenu."
+ self model
+ ifNotNil: [:mod |
+ mod
+ addModelYellowButtonMenuItemsTo: aCustomMenu
+ forMorph: self
+ hand: evt hand]!
Item was added:
+ ----- Method: Morph>>addMorph: (in category 'submorphs-add/remove') -----
+ addMorph: aMorph
+
+ self addMorphFront: aMorph.!
Item was added:
+ ----- Method: Morph>>addMorph:after: (in category 'submorphs-add/remove') -----
+ addMorph: newMorph after: aMorph
+ ^self addMorph: newMorph behind: aMorph!
Item was added:
+ ----- Method: Morph>>addMorph:asElementNumber: (in category 'submorphs-add/remove') -----
+ addMorph: aMorph asElementNumber: aNumber
+ "Add the given morph so that it becomes the aNumber'th element of my submorph list. If aMorph is already one of my submorphs, reposition it"
+
+ (submorphs includes: aMorph) ifTrue:
+ [aMorph privateDelete].
+ (aNumber <= submorphs size)
+ ifTrue:
+ [self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
+ ifFalse:
+ [self addMorphBack: aMorph]
+ !
Item was added:
+ ----- Method: Morph>>addMorph:behind: (in category 'submorphs-add/remove') -----
+ addMorph: newMorph behind: aMorph
+ "Add a morph to the list of submorphs behind the specified morph"
+ ^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph) + 1.
+ !
Item was added:
+ ----- Method: Morph>>addMorph:fullFrame: (in category 'submorphs-add/remove') -----
+ addMorph: aMorph fullFrame: aLayoutFrame
+
+ aMorph layoutFrame: aLayoutFrame.
+ aMorph hResizing: #spaceFill; vResizing: #spaceFill.
+ self addMorph: aMorph.
+
+ !
Item was added:
+ ----- Method: Morph>>addMorph:inFrontOf: (in category 'submorphs-add/remove') -----
+ addMorph: newMorph inFrontOf: aMorph
+ "Add a morph to the list of submorphs in front of the specified morph"
+ ^self privateAddMorph: newMorph atIndex: ((submorphs indexOf: aMorph) max: 1).!
Item was added:
+ ----- Method: Morph>>addMorphBack: (in category 'submorphs-add/remove') -----
+ addMorphBack: aMorph
+ ^self privateAddMorph: aMorph atIndex: submorphs size+1!
Item was added:
+ ----- Method: Morph>>addMorphCentered: (in category 'submorphs-add/remove') -----
+ addMorphCentered: aMorph
+
+ aMorph position: bounds center - (aMorph extent // 2).
+ self addMorphFront: aMorph.
+ !
Item was added:
+ ----- Method: Morph>>addMorphFront: (in category 'submorphs-add/remove') -----
+ addMorphFront: aMorph
+ ^self privateAddMorph: aMorph atIndex: 1!
Item was added:
+ ----- Method: Morph>>addMorphFront:fromWorldPosition: (in category 'submorphs-add/remove') -----
+ addMorphFront: aMorph fromWorldPosition: wp
+
+ self addMorphFront: aMorph.
+ aMorph position: (self transformFromWorld globalPointToLocal: wp)!
Item was added:
+ ----- Method: Morph>>addMorphFrontFromWorldPosition: (in category 'submorphs-add/remove') -----
+ addMorphFrontFromWorldPosition: aMorph
+ ^self addMorphFront: aMorph fromWorldPosition: aMorph positionInWorld.!
Item was added:
+ ----- Method: Morph>>addMorphInFrontOfLayer: (in category 'WiW support') -----
+ addMorphInFrontOfLayer: aMorph
+
+ | targetLayer |
+
+ targetLayer := aMorph morphicLayerNumberWithin: self.
+ submorphs do: [ :each | | layerHere |
+ each == aMorph ifTrue: [^self].
+ layerHere := each morphicLayerNumberWithin: self.
+ "the <= is the difference - it insures we go to the front of our layer"
+ targetLayer <= layerHere ifTrue: [
+ ^self addMorph: aMorph inFrontOf: each
+ ].
+ ].
+ self addMorphBack: aMorph.
+ !
Item was added:
+ ----- Method: Morph>>addMorphInLayer: (in category 'WiW support') -----
+ addMorphInLayer: aMorph
+
+ submorphs do: [ :each |
+ each == aMorph ifTrue: [^self].
+ aMorph morphicLayerNumber < each morphicLayerNumber ifTrue: [
+ ^self addMorph: aMorph inFrontOf: each
+ ].
+ ].
+ self addMorphBack: aMorph
+ !
Item was added:
+ ----- Method: Morph>>addMorphNearBack: (in category 'submorphs-add/remove') -----
+ addMorphNearBack: aMorph
+ | bg |
+ (submorphs notEmpty and: [submorphs last mustBeBackmost])
+ ifTrue:
+ [bg := submorphs last.
+ bg privateDelete].
+ self addMorphBack: aMorph.
+ bg ifNotNil: [self addMorphBack: bg]!
Item was added:
+ ----- Method: Morph>>addMorphsTo:pianoRoll:eventTime:betweenTime:and: (in category '*Morphic-Sound-piano rolls') -----
+ addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime
+
+ "a hack to allow for abitrary morphs to be dropped into piano roll"
+ t > rightTime ifTrue: [^ self].
+ t < leftTime ifTrue: [^ self].
+ morphList add: (self left: (pianoRoll xForTime: t)).
+ !
Item was added:
+ ----- Method: Morph>>addMouseActionIndicatorsWidth:color: (in category 'debug and other') -----
+ addMouseActionIndicatorsWidth: anInteger color: aColor
+
+ self deleteAnyMouseActionIndicators.
+
+ self changed.
+ self hasRolloverBorder: true.
+ self setProperty: #rolloverWidth toValue: anInteger at anInteger.
+ self setProperty: #rolloverColor toValue: aColor.
+ self layoutChanged.
+ self changed.
+
+ !
Item was added:
+ ----- Method: Morph>>addMouseUpAction (in category 'debug and other') -----
+ addMouseUpAction
+ | codeToRun oldCode |
+ oldCode := self
+ valueOfProperty: #mouseUpCodeToRun
+ ifAbsent: [''].
+ codeToRun := UIManager default request: 'MouseUp expression:' translated initialAnswer: oldCode.
+ self addMouseUpActionWith: codeToRun!
Item was added:
+ ----- Method: Morph>>addMouseUpActionWith: (in category 'debug and other') -----
+ addMouseUpActionWith: codeToRun
+ ((codeToRun isMessageSend) not and: [codeToRun isEmptyOrNil])
+ ifTrue: [^self].
+ self setProperty: #mouseUpCodeToRun toValue: codeToRun.
+ self
+ on: #mouseUp
+ send: #programmedMouseUp:for:
+ to: self.
+ self
+ on: #mouseDown
+ send: #programmedMouseDown:for:
+ to: self.
+ self
+ on: #mouseEnter
+ send: #programmedMouseEnter:for:
+ to: self.
+ self
+ on: #mouseLeave
+ send: #programmedMouseLeave:for:
+ to: self!
Item was added:
+ ----- Method: Morph>>addMyYellowButtonMenuItemsToSubmorphMenus (in category 'menu') -----
+ addMyYellowButtonMenuItemsToSubmorphMenus
+ "Answer true if I have items to add to the context menus of my submorphs"
+
+ ^true!
Item was added:
+ ----- Method: Morph>>addNestedYellowButtonItemsTo:event: (in category 'menu') -----
+ addNestedYellowButtonItemsTo: aMenu event: evt
+ "Add items to aMenu starting with me and proceeding down
+ through my submorph chain,
+ letting any submorphs that include the event position
+ contribute their items to the bottom of the menu, separated by
+ a line."
+ | underMouse |
+
+ self addYellowButtonMenuItemsTo: aMenu event: evt.
+
+ underMouse := self
+ submorphThat: [:each | each containsPoint: evt position]
+ ifNone: [^ self].
+
+ (underMouse addMyYellowButtonMenuItemsToSubmorphMenus
+ and: [underMouse hasYellowButtonMenu])
+ ifTrue: [| submenu |
+ aMenu addLine.
+ submenu := MenuMorph new defaultTarget: underMouse.
+ underMouse addNestedYellowButtonItemsTo: submenu event: evt.
+ aMenu
+ add: underMouse externalName
+ icon: (underMouse iconOrThumbnailOfSize: 16)
+ subMenu: submenu
+ ]
+ !
Item was added:
+ ----- Method: Morph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
+ addOptionalHandlesTo: aHalo box: box
+ aHalo addDirectionHandles!
Item was added:
+ ----- Method: Morph>>addPaintingItemsTo:hand: (in category 'menus') -----
+ addPaintingItemsTo: aMenu hand: aHandMorph
+ | subMenu movies |
+ subMenu := MenuMorph new defaultTarget: self.
+ subMenu add: 'repaint' translated action: #editDrawing.
+ subMenu add: 'set rotation center' translated action: #setRotationCenter.
+ subMenu add: 'reset forward-direction' translated
+ action: #resetForwardDirection.
+ subMenu add: 'set rotation style' translated action: #setRotationStyle.
+ subMenu add: 'erase pixels of color' translated
+ action: #erasePixelsUsing:.
+ subMenu add: 'recolor pixels of color' translated
+ action: #recolorPixelsUsing:.
+ subMenu add: 'reduce color palette' translated action: #reduceColorPalette:.
+ subMenu add: 'add a border around this shape...' translated
+ action: #addBorderToShape:.
+ movies := (self world rootMorphsAt: aHandMorph targetPoint)
+ select: [:m | (m isKindOf: MovieMorph) or: [m isSketchMorph]].
+ movies size > 1
+ ifTrue:
+ [subMenu add: 'insert into movie' translated action: #insertIntoMovie:].
+ aMenu add: 'painting...' translated subMenu: subMenu!
Item was added:
+ ----- Method: Morph>>addSimpleHandlesTo:box: (in category 'halos and balloon help') -----
+ addSimpleHandlesTo: aHaloMorph box: aBox
+ ^ aHaloMorph addSimpleHandlesTo: aHaloMorph box: aBox!
Item was added:
+ ----- Method: Morph>>addStandardHaloMenuItemsTo:hand: (in category 'menus') -----
+ addStandardHaloMenuItemsTo: aMenu hand: aHandMorph
+ "Add standard halo items to the menu"
+
+ | unlockables |
+
+ self isWorldMorph ifTrue:
+ [^ self addWorldHaloMenuItemsTo: aMenu hand: aHandMorph].
+
+ self mustBeBackmost ifFalse:
+ [aMenu add: 'send to back' translated action: #goBehind.
+ aMenu add: 'bring to front' translated action: #comeToFront.
+ self addEmbeddingMenuItemsTo: aMenu hand: aHandMorph.
+ aMenu addLine].
+
+ self addFillStyleMenuItems: aMenu hand: aHandMorph.
+ self addBorderStyleMenuItems: aMenu hand: aHandMorph.
+ self addDropShadowMenuItems: aMenu hand: aHandMorph.
+ self addLayoutMenuItems: aMenu hand: aHandMorph.
+ self addHaloActionsTo: aMenu.
+ owner isTextMorph ifTrue:[self addTextAnchorMenuItems: aMenu hand: aHandMorph].
+ aMenu addLine.
+ self addToggleItemsToHaloMenu: aMenu.
+ aMenu addLine.
+ self addCopyItemsTo: aMenu.
+ self addPlayerItemsTo: aMenu.
+ self addExportMenuItems: aMenu hand: aHandMorph.
+ self addStackItemsTo: aMenu.
+ self addMiscExtrasTo: aMenu.
+ Preferences noviceMode ifFalse:
+ [self addDebuggingItemsTo: aMenu hand: aHandMorph].
+
+ aMenu addLine.
+ aMenu defaultTarget: self.
+
+ aMenu addLine.
+
+ unlockables := self submorphs select:
+ [:m | m isLocked].
+ unlockables size = 1 ifTrue:
+ [aMenu
+ add: ('unlock "{1}"' translated format: unlockables first externalName)
+ action: #unlockContents].
+ unlockables size > 1 ifTrue:
+ [aMenu add: 'unlock all contents' translated action: #unlockContents.
+ aMenu add: 'unlock...' translated action: #unlockOneSubpart].
+
+ aMenu defaultTarget: aHandMorph.
+ !
Item was added:
+ ----- Method: Morph>>addTableLayoutMenuItems:hand: (in category 'layout-menu') -----
+ addTableLayoutMenuItems: aMenu hand: aHand
+ | menu sub |
+ menu := MenuMorph new defaultTarget: self.
+ menu addUpdating: #hasReverseCellsString action: #changeReverseCells.
+ menu addUpdating: #hasClipLayoutCellsString action: #changeClipLayoutCells.
+ menu addUpdating: #hasRubberBandCellsString action: #changeRubberBandCells.
+ menu addLine.
+ menu add: 'change cell inset...' translated action: #changeCellInset:.
+ menu add: 'change min cell size...' translated action: #changeMinCellSize:.
+ menu add: 'change max cell size...' translated action: #changeMaxCellSize:.
+ menu addLine.
+
+ sub := MenuMorph new defaultTarget: self.
+ #(leftToRight rightToLeft topToBottom bottomToTop) do:[:sym|
+ sub addUpdating: #listDirectionString: target: self selector: #changeListDirection: argumentList: (Array with: sym)].
+ menu add: 'list direction' translated subMenu: sub.
+
+ sub := MenuMorph new defaultTarget: self.
+ #(none leftToRight rightToLeft topToBottom bottomToTop) do:[:sym|
+ sub addUpdating: #wrapDirectionString: target: self selector: #wrapDirection: argumentList: (Array with: sym)].
+ menu add: 'wrap direction' translated subMenu: sub.
+
+ sub := MenuMorph new defaultTarget: self.
+ #(center topLeft topRight bottomLeft bottomRight topCenter leftCenter rightCenter bottomCenter) do:[:sym|
+ sub addUpdating: #cellPositioningString: target: self selector: #cellPositioning: argumentList: (Array with: sym)].
+ menu add: 'cell positioning' translated subMenu: sub.
+
+ sub := MenuMorph new defaultTarget: self.
+ #(topLeft bottomRight center justified) do:[:sym|
+ sub addUpdating: #listCenteringString: target: self selector: #listCentering: argumentList: (Array with: sym)].
+ menu add: 'list centering' translated subMenu: sub.
+
+ sub := MenuMorph new defaultTarget: self.
+ #(topLeft bottomRight center justified) do:[:sym|
+ sub addUpdating: #wrapCenteringString: target: self selector: #wrapCentering: argumentList: (Array with: sym)].
+ menu add: 'wrap centering' translated subMenu: sub.
+
+ sub := MenuMorph new defaultTarget: self.
+ #(none equal) do:[:sym|
+ sub addUpdating: #listSpacingString: target: self selector: #listSpacing: argumentList: (Array with: sym)].
+ menu add: 'list spacing' translated subMenu: sub.
+
+ sub := MenuMorph new defaultTarget: self.
+ #(none localRect localSquare globalRect globalSquare) do:[:sym|
+ sub addUpdating: #cellSpacingString: target: self selector: #cellSpacing: argumentList: (Array with: sym)].
+ menu add: 'cell spacing' translated subMenu: sub.
+
+ aMenu ifNotNil:[aMenu add: 'table layout' translated subMenu: menu].
+ ^menu!
Item was added:
+ ----- Method: Morph>>addTextAnchorMenuItems:hand: (in category 'text-anchor') -----
+ addTextAnchorMenuItems: topMenu hand: aHand
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu addUpdating: #hasInlineAnchorString action: #changeInlineAnchor.
+ aMenu addUpdating: #hasParagraphAnchorString action: #changeParagraphAnchor.
+ aMenu addUpdating: #hasDocumentAnchorString action: #changeDocumentAnchor.
+ topMenu ifNotNil:[topMenu add: 'text anchor' subMenu: aMenu].
+ ^aMenu!
Item was added:
+ ----- Method: Morph>>addTitleForHaloMenu: (in category 'menu') -----
+ addTitleForHaloMenu: aMenu
+ aMenu
+ addTitle: self externalName
+ icon: (self iconOrThumbnailOfSize: (Preferences tinyDisplay ifFalse:[28] ifTrue:[16]))!
Item was added:
+ ----- Method: Morph>>addToggleItemsToHaloMenu: (in category 'menus') -----
+ addToggleItemsToHaloMenu: aMenu
+ "Add standard true/false-checkbox items to the memu"
+
+ #(
+ (resistsRemovalString toggleResistsRemoval 'whether I should be reistant to easy deletion via the pink X handle' true)
+ (stickinessString toggleStickiness 'whether I should be resistant to a drag done by mousing down on me' true)
+ (lockedString lockUnlockMorph 'when "locked", I am inert to all user interactions' true)
+ (hasClipSubmorphsString changeClipSubmorphs 'whether the parts of objects within me that are outside my bounds should be masked.' false)
+ (hasDirectionHandlesString changeDirectionHandles 'whether direction handles are shown with the halo' false)
+ (hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me' false)
+ )
+ select:[:each | Preferences noviceMode not or:[each fourth]]
+ thenDo:
+ [:each |
+ aMenu addUpdating: each first action: each second.
+ aMenu balloonTextForLastItem: each third translated].
+
+ self couldHaveRoundedCorners ifTrue:
+ [aMenu addUpdating: #roundedCornersString action: #toggleCornerRounding.
+ aMenu balloonTextForLastItem: 'whether my corners should be rounded' translated]!
Item was added:
+ ----- Method: Morph>>addViewingItemsTo: (in category 'debug and other') -----
+ addViewingItemsTo: aMenu
+ "Add viewing-related items to the given menu. If any are added, this method is also responsible for adding a line after them"!
Item was added:
+ ----- Method: Morph>>addWorldHandlesTo:box: (in category 'halos and balloon help') -----
+ addWorldHandlesTo: aHaloMorph box: box
+ aHaloMorph haloBox: box.
+ Preferences haloSpecificationsForWorld do:
+ [:aSpec |
+ aHaloMorph perform: aSpec addHandleSelector with: aSpec].
+ aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box!
Item was added:
+ ----- Method: Morph>>addWorldTargetSightingItems:hand: (in category 'menus') -----
+ addWorldTargetSightingItems: aCustomMenu hand: aHandMorph
+ "Use cursor to select a point on screen.
+ Set target from all possible morphs under cursor sight."
+
+ aCustomMenu addLine.
+
+ aCustomMenu add: 'sight target' translated action: #sightWorldTargets:.
+ !
Item was added:
+ ----- Method: Morph>>addYellowButtonMenuItemsTo:event: (in category 'menu') -----
+ addYellowButtonMenuItemsTo: aMenu event: evt
+ "Populate aMenu with appropriate menu items for a
+ yellow-button (context menu) click."
+ aMenu defaultTarget: self.
+ ""
+ Preferences noviceMode
+ ifFalse: [aMenu addStayUpItem].
+ ""
+ self addModelYellowButtonItemsTo: aMenu event: evt.
+ ""
+ Preferences generalizedYellowButtonMenu
+ ifFalse: [^ self].
+ ""
+ Preferences cmdGesturesEnabled
+ ifTrue: [""
+ aMenu addLine.
+ aMenu add: 'inspect' translated action: #inspect].
+ ""
+ aMenu addLine.
+ self world selectedObject == self
+ ifTrue: [aMenu add: 'deselect' translated action: #removeHalo]
+ ifFalse: [aMenu add: 'select' translated action: #addHalo].
+ ""
+ (self isWorldMorph
+ or: [self mustBeBackmost
+ or: [self wantsToBeTopmost]])
+ ifFalse: [""
+ aMenu addLine.
+ aMenu add: 'send to back' translated action: #goBehind.
+ aMenu add: 'bring to front' translated action: #comeToFront.
+ self addEmbeddingMenuItemsTo: aMenu hand: evt hand].
+ ""
+ self isWorldMorph
+ ifFalse: [""
+ Smalltalk
+ at: #NCAAConnectorMorph
+ ifPresent: [:connectorClass |
+ aMenu addLine.
+ aMenu add: 'connect to' translated action: #startWiring.
+ aMenu addLine].
+ ""
+
+ self isFullOnScreen
+ ifFalse: [aMenu add: 'move onscreen' translated action: #goHome]].
+ ""
+ Preferences noviceMode
+ ifFalse: [""
+ self addLayoutMenuItems: aMenu hand: evt hand.
+ (owner notNil
+ and: [owner isTextMorph])
+ ifTrue: [self addTextAnchorMenuItems: aMenu hand: evt hand]].
+ ""
+ self isWorldMorph
+ ifFalse: [""
+ aMenu addLine.
+ self addToggleItemsToHaloMenu: aMenu].
+ ""
+ aMenu addLine.
+ self isWorldMorph
+ ifFalse: [aMenu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:].
+ (self allStringsAfter: nil) isEmpty
+ ifFalse: [aMenu add: 'copy text' translated action: #clipText].
+ ""
+ self addExportMenuItems: aMenu hand: evt hand.
+ ""
+ (Preferences noviceMode not
+ and: [self isWorldMorph not])
+ ifTrue: [""
+ aMenu addLine.
+ aMenu add: 'adhere to edge...' translated action: #adhereToEdge].
+ ""
+ self addCustomMenuItems: aMenu hand: evt hand!
Item was added:
+ ----- Method: Morph>>addedMorph: (in category 'change reporting') -----
+ addedMorph: aMorph
+ "Notify the receiver that the given morph was just added."
+ !
Item was added:
+ ----- Method: Morph>>adhereToEdge (in category 'menus') -----
+ adhereToEdge
+ | menu |
+ menu := MenuMorph new defaultTarget: self.
+ #(top right bottom left - center - topLeft topRight bottomRight bottomLeft - none)
+ do: [:each |
+ each == #-
+ ifTrue: [menu addLine]
+ ifFalse: [menu add: each asString translated selector: #setToAdhereToEdge: argument: each]].
+ menu popUpEvent: self currentEvent in: self world!
Item was added:
+ ----- Method: Morph>>adhereToEdge: (in category 'menus') -----
+ adhereToEdge: edgeSymbol
+ | edgeMessage |
+ (owner isNil or: [owner isHandMorph]) ifTrue: [^self].
+ (owner class canUnderstand: edgeSymbol) ifFalse: [^self].
+ (self class canUnderstand: ( edgeMessage := (edgeSymbol , ':') asSymbol ))
+ ifFalse: [^self].
+
+ self perform: edgeMessage
+ withArguments: (Array with: (owner perform: edgeSymbol))!
Item was added:
+ ----- Method: Morph>>adjustLayoutBounds (in category 'layout') -----
+ adjustLayoutBounds
+ "Adjust the receivers bounds depending on the resizing strategy imposed"
+ | hFit vFit box myExtent extent |
+ hFit := self hResizing.
+ vFit := self vResizing.
+ (hFit == #shrinkWrap or:[vFit == #shrinkWrap]) ifFalse:[^self]. "not needed"
+ box := self layoutBounds.
+ myExtent := box extent.
+ extent := self submorphBounds corner - box origin.
+ hFit == #shrinkWrap ifTrue:[myExtent := extent x @ myExtent y].
+ vFit == #shrinkWrap ifTrue:[myExtent := myExtent x @ extent y].
+ "Make sure we don't get smaller than minWidth/minHeight"
+ myExtent x < self minWidth ifTrue:[
+ myExtent := (myExtent x max:
+ (self minWidth - self bounds width + self layoutBounds width)) @ myExtent y].
+ myExtent y < self minHeight ifTrue:[
+ myExtent := myExtent x @ (myExtent y max:
+ (self minHeight - self bounds height + self layoutBounds height))].
+ self layoutBounds: (box origin extent: myExtent).!
Item was added:
+ ----- Method: Morph>>adjustedCenter (in category 'menus') -----
+ adjustedCenter
+ "Provides a hook for objects to provide a reference point other than the receiver's center,for the purpose of centering a submorph under special circumstances, such as BalloonMorph"
+
+ ^ self center!
Item was added:
+ ----- Method: Morph>>adjustedCenter: (in category 'menus') -----
+ adjustedCenter: c
+ "Set the receiver's position based on the #adjustedCenter protocol for adhereToEdge. By default this simply sets the receiver's center. Though there are (at its inception anyway) no other implementors of this method, it is required in use with the #adhereToEdge when the centering of a submorph is to be with reference to a rectangle other than the receiver's center."
+
+ self center: c!
Item was added:
+ ----- Method: Morph>>adoptPaneColor: (in category 'accessing') -----
+ adoptPaneColor: paneColor
+ self submorphsDo:[:m| m adoptPaneColor: paneColor].!
Item was added:
+ ----- Method: Morph>>alarmScheduler (in category 'events-alarms') -----
+ alarmScheduler
+ "Return the scheduler being responsible for triggering alarms"
+ ^self world!
Item was added:
+ ----- Method: Morph>>align:with: (in category 'geometry') -----
+ align: aPoint1 with: aPoint2
+ "Translate by aPoint2 - aPoint1."
+
+ ^ self position: self position + (aPoint2 - aPoint1)!
Item was added:
+ ----- Method: Morph>>allKnownNames (in category 'submorphs-accessing') -----
+ allKnownNames
+ "Return a list of all known names based on the scope of the receiver. Does not include the name of the receiver itself. Items in parts bins are excluded. Reimplementors (q.v.) can extend the list"
+
+ ^ Array streamContents:
+ [:s | self allSubmorphNamesDo: [:n | s nextPut: n]]
+ !
Item was added:
+ ----- Method: Morph>>allMenuWordings (in category 'menus') -----
+ allMenuWordings
+ | tempMenu |
+ tempMenu := self buildHandleMenu: self currentHand.
+ tempMenu allMorphsDo: [:m | m step]. "Get wordings current"
+ ^ tempMenu allWordings!
Item was added:
+ ----- Method: Morph>>allMorphs (in category 'submorphs-accessing') -----
+ allMorphs
+ "Return a collection containing all morphs in this composite morph (including the receiver)."
+
+ | all |
+ all := OrderedCollection new: 100.
+ self allMorphsDo: [: m | all add: m].
+ ^ all!
Item was added:
+ ----- Method: Morph>>allMorphsAndBookPagesInto: (in category 'e-toy support') -----
+ allMorphsAndBookPagesInto: aSet
+ "Return a set of all submorphs. Don't forget the hidden ones like BookMorph pages that are not showing. Consider only objects that are in memory (see allNonSubmorphMorphs)."
+
+ submorphs do: [:m | m allMorphsAndBookPagesInto: aSet].
+ self allNonSubmorphMorphs do: [:m |
+ (aSet includes: m) ifFalse: ["Stop infinite recursion"
+ m allMorphsAndBookPagesInto: aSet]].
+ aSet add: self.
+ self player ifNotNil:
+ [self player allScriptEditors do: [:e | e allMorphsAndBookPagesInto: aSet]].
+ ^ aSet!
Item was added:
+ ----- Method: Morph>>allMorphsDo: (in category 'submorphs-accessing') -----
+ allMorphsDo: aBlock
+ "Evaluate the given block for all morphs in this composite morph (including the receiver)."
+
+ submorphs do: [:m | m allMorphsDo: aBlock].
+ aBlock value: self!
Item was added:
+ ----- Method: Morph>>allMorphsWithPlayersDo: (in category 'submorphs-add/remove') -----
+ allMorphsWithPlayersDo: aTwoArgumentBlock
+ "Evaluate the given block for all morphs in this composite morph that have non-nil players.
+ Also evaluate the block for the receiver if it has a player."
+
+ submorphs do: [:m | m allMorphsWithPlayersDo: aTwoArgumentBlock ].
+ self playerRepresented ifNotNil: [ :p | aTwoArgumentBlock value: self value: p ].
+ !
Item was added:
+ ----- Method: Morph>>allNonSubmorphMorphs (in category 'submorphs-accessing') -----
+ allNonSubmorphMorphs
+ "Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy (put in primarily for bookmorphs)"
+
+ ^ OrderedCollection new!
Item was added:
+ ----- Method: Morph>>allOwners (in category 'structure') -----
+ allOwners
+ "Return the owners of the reciever"
+
+ ^ Array streamContents: [:strm | self allOwnersDo: [:m | strm nextPut: m]]!
Item was added:
+ ----- Method: Morph>>allOwnersDo: (in category 'structure') -----
+ allOwnersDo: aBlock
+ "Evaluate aBlock with all owners of the receiver"
+ owner ifNotNil:[^owner withAllOwnersDo: aBlock].!
Item was added:
+ ----- Method: Morph>>allStringsAfter: (in category 'debug and other') -----
+ allStringsAfter: aSubmorph
+ "return an OrderedCollection of strings of text in my submorphs. If aSubmorph is non-nil, begin with that container."
+
+ | list ok |
+ list := OrderedCollection new.
+ ok := aSubmorph isNil.
+ self allMorphsDo:
+ [:sub | | string |
+ ok ifFalse: [ok := sub == aSubmorph]. "and do this one too"
+ ok
+ ifTrue:
+ [(string := sub userString) ifNotNil:
+ [string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]].
+ ^list!
Item was added:
+ ----- Method: Morph>>allSubmorphNamesDo: (in category 'submorphs-accessing') -----
+ allSubmorphNamesDo: nameBlock
+ "Return a list of all known names of submorphs and nested submorphs of the receiver, based on the scope of the receiver. Items in parts bins are excluded"
+
+ self isPartsBin ifTrue: [^ self]. "Don't report names from parts bins"
+ self submorphsDo:
+ [:m | m knownName ifNotNil: [:n | nameBlock value: n].
+ m allSubmorphNamesDo: nameBlock].
+ !
Item was added:
+ ----- Method: Morph>>allowsGestureStart: (in category 'geniestubs') -----
+ allowsGestureStart: evt
+ ^false!
Item was added:
+ ----- Method: Morph>>altSpecialCursor0 (in category 'debug and other') -----
+ altSpecialCursor0
+ "an arrow"
+ ^(Form
+ extent: 16 at 16
+ depth: 8
+ fromArray: #( 0 0 0 0 14869218 3806520034 3806520034 3791650816 14848144 2425393296 2425393378 0 14848144 2425393296 2425414144 0 14848144 2425393296 2430730240 0 14848144 2425393296 3791650816 0 14848144 2425393378 3791650816 0 14848144 2425414370 3806461952 0 14848144 2430788322 3806519808 0 14848144 3791651042 3806520034 0 14848226 0 3806520034 3791650816 14868992 0 14869218 3806461952 14811136 0 58082 3806519808 0 0 226 3806520034 0 0 0 3806520034 0 0 0 14869218)
+ offset: 0 at 0)
+ !
Item was added:
+ ----- Method: Morph>>altSpecialCursor1 (in category 'debug and other') -----
+ altSpecialCursor1
+ "a star and an arrow"
+ ^(Form
+ extent: 31 at 26
+ depth: 8
+ fromArray: #( 14417920 0 0 0 0 0 0 0 3705461980 3705461980 3705405440 0 0 0 0 0 3705461980 3705461980 3705461760 0 0 0 0 0 14474460 3705461980 3705405440 0 0 0 0 0 56540 3705461980 3690987520 0 0 3690987520 0 0 220 3705461980 3705461760 0 0 3690987520 0 0 220 3705405440 3705461980 0 0 3705405440 0 0 0 3705461760 56540 3690987520 220 3705405440 0 0 0 3705405440 220 3705461760 220 3705405440 0 0 0 0 0 14474460 220 3705461760 0 0 0 0 0 56540 3691044060 3705461760 0 0 0 0 0 220 3705461980 3705461760 0 0 0 0 56540 3705461980 3705461980 3705461980 3705461980 3705461760 0 0 220 3705461980 3705461980 3705461980 3705461980 3705461760 0 0 0 3705461980 3705461980 3705461980 3705461980 3705405440 0 0 0 14474460 3705461980 3705461980 3705461980 3690987520 0 0 0 56540 3705461980 3705461980 3705461760 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 0 3705461980 3705461980 3690987520 0 0 0 0 0 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 14474460 3705405440 0 0 0 0 220 3705405440 220 3705461760 0 0 0 0 56540 3690987520 0 3705461760 0 0 0 0 56540 0 0 14474240 0)
+ offset: 0 at 0)!
Item was added:
+ ----- Method: Morph>>altSpecialCursor2 (in category 'debug and other') -----
+ altSpecialCursor2
+ | f |
+ "a blue box with transparent center"
+ f := Form extent: 32 at 32 depth: 32.
+ f offset: (f extent // 2) negated.
+ f fill: f boundingBox rule: Form over fillColor: (Color blue alpha: 0.5).
+ f fill: (f boundingBox insetBy: 4) rule: Form over fillColor: Color transparent.
+ ^f
+ !
Item was added:
+ ----- Method: Morph>>altSpecialCursor3 (in category 'debug and other') -----
+ altSpecialCursor3
+
+ ^self altSpecialCursor3: Color blue!
Item was added:
+ ----- Method: Morph>>altSpecialCursor3: (in category 'debug and other') -----
+ altSpecialCursor3: aColor
+ | f box |
+ "a bulls-eye pattern in this color"
+ f := Form extent: 32 at 32 depth: 32.
+ f offset: (f extent // 2) negated.
+ box := f boundingBox.
+ [ box width > 0] whileTrue: [
+ f fill: box rule: Form over fillColor: aColor.
+ f fill: (box insetBy: 2) rule: Form over fillColor: Color transparent.
+ box := box insetBy: 4.
+ ].
+ ^f
+ !
Item was added:
+ ----- Method: Morph>>applyStatusToAllSiblings: (in category 'meta-actions') -----
+ applyStatusToAllSiblings: evt
+ "Apply the statuses of all my scripts to the script status of all my siblings"
+
+ | aPlayer |
+ (aPlayer := self topRendererOrSelf player) belongsToUniClass ifFalse: [self error: 'not uniclass'].
+ aPlayer instantiatedUserScriptsDo:
+ [:aScriptInstantiation | aScriptInstantiation assignStatusToAllSiblings]!
Item was added:
+ ----- Method: Morph>>areasRemainingToFill: (in category 'drawing') -----
+ areasRemainingToFill: aRectangle
+ "May be overridden by any subclasses with opaque regions"
+
+ ^ Array with: aRectangle!
Item was added:
+ ----- Method: Morph>>arrangeToStartStepping (in category 'stepping and presenter') -----
+ arrangeToStartStepping
+ "Arrange to start getting sent the 'step' message, but don't do that initial #step call that startStepping does"
+
+ self arrangeToStartSteppingIn: self world!
Item was added:
+ ----- Method: Morph>>arrangeToStartSteppingIn: (in category 'stepping and presenter') -----
+ arrangeToStartSteppingIn: aWorld
+ "Start getting sent the 'step' message in aWorld. Like startSteppingIn:, but without the initial one to get started'"
+ aWorld ifNotNil:
+ [aWorld startStepping: self.
+ self changed]!
Item was added:
+ ----- Method: Morph>>asDraggableMorph (in category 'converting') -----
+ asDraggableMorph
+ ^self!
Item was added:
+ ----- Method: Morph>>asMorph (in category 'creation') -----
+ asMorph
+ ^ self!
Item was added:
+ ----- Method: Morph>>asNumber: (in category 'e-toy support') -----
+ asNumber: aPointOrNumber
+ "Support for e-toy demo."
+
+ aPointOrNumber class = Point
+ ifTrue: [^ aPointOrNumber r]
+ ifFalse: [^ aPointOrNumber].
+ !
Item was added:
+ ----- Method: Morph>>asPostscript (in category '*morphic-Postscript Canvases') -----
+ asPostscript
+ ^self asEPS.
+ !
Item was added:
+ ----- Method: Morph>>asSnapshotThumbnail (in category 'converting') -----
+ asSnapshotThumbnail
+ ^(ThumbnailImageMorph new newImage: self imageForm ) extent: 90 asPoint .!
Item was added:
+ ----- Method: Morph>>assureExtension (in category 'accessing - extension') -----
+ assureExtension
+ "creates an extension for the receiver if needed"
+ extension ifNil: [self initializeExtension].
+ ^ extension!
Item was added:
+ ----- Method: Morph>>assureExternalName (in category 'player') -----
+ assureExternalName
+ | aName |
+ ^ (aName := self knownName) ifNil:
+ [self setNameTo: (aName := self externalName).
+ ^ aName]!
Item was added:
+ ----- Method: Morph>>assureLayoutProperties (in category 'layout-properties') -----
+ assureLayoutProperties
+ | props |
+ props := self layoutProperties.
+ props == self ifTrue:[props := nil].
+ props ifNil:[
+ props := LayoutProperties new initializeFrom: self.
+ self layoutProperties: props].
+ ^props!
Item was added:
+ ----- Method: Morph>>assureTableProperties (in category 'layout-properties') -----
+ assureTableProperties
+ | props |
+ props := self layoutProperties.
+ props == self ifTrue:[props := nil].
+ props ifNil:[
+ props := TableLayoutProperties new initializeFrom: self.
+ self layoutProperties: props].
+ props includesTableProperties
+ ifFalse:[self layoutProperties: (props := props asTableLayoutProperties)].
+ ^props!
Item was added:
+ ----- Method: Morph>>attachToResource (in category 'fileIn/out') -----
+ attachToResource
+ "Produce a morph from a file -- either a saved .morph file or a graphics file"
+
+ | pathName |
+ pathName := Utilities chooseFileWithSuffixFromList: (#('.morph'), Utilities graphicsFileSuffixes)
+ withCaption: 'Choose a file
+ to load'.
+ pathName ifNil: [^ self]. "User made no choice"
+ pathName == #none ifTrue: [^ self inform:
+ 'Sorry, no suitable files found
+ (names should end with .morph, .gif,
+ .bmp, .jpeg, .jpe, .jp, or .form)'].
+
+ self setProperty: #resourceFilePath toValue: pathName!
Item was added:
+ ----- Method: Morph>>automaticViewing (in category 'e-toy support') -----
+ automaticViewing
+ "Backstop, in case this message gets sent to an owner that is not a playfield"
+ ^ false!
Item was added:
+ ----- Method: Morph>>balloonColor (in category 'halos and balloon help') -----
+ balloonColor
+ ^ self
+ valueOfProperty: #balloonColor
+ ifAbsent: [self defaultBalloonColor]!
Item was added:
+ ----- Method: Morph>>balloonColor: (in category 'halos and balloon help') -----
+ balloonColor: aColor
+ ^ self
+ setProperty: #balloonColor
+ toValue: aColor!
Item was added:
+ ----- Method: Morph>>balloonFont (in category 'halos and balloon help') -----
+ balloonFont
+ ^ self
+ valueOfProperty: #balloonFont
+ ifAbsent: [self defaultBalloonFont]!
Item was added:
+ ----- Method: Morph>>balloonFont: (in category 'halos and balloon help') -----
+ balloonFont: aFont
+ ^ self setProperty: #balloonFont toValue: aFont!
Item was added:
+ ----- Method: Morph>>balloonHelpAligner (in category 'halos and balloon help') -----
+ balloonHelpAligner
+ "Answer the morph to which the receiver's balloon help should point"
+ ^ (self valueOfProperty: #balloonTarget) ifNil: [self]!
Item was added:
+ ----- Method: Morph>>balloonHelpDelayTime (in category 'halos and balloon help') -----
+ balloonHelpDelayTime
+ "Return the number of milliseconds before a balloon help should be put up on the receiver. The balloon help will only be put up if the receiver responds to #wantsBalloon by returning true."
+ ^ Preferences balloonHelpDelayTime!
Item was added:
+ ----- Method: Morph>>balloonHelpTextForHandle: (in category 'halos and balloon help') -----
+ balloonHelpTextForHandle: aHandle
+ "Answer a string providing balloon help for the
+ given halo handle"
+ | itsSelector |
+ itsSelector := aHandle eventHandler firstMouseSelector.
+ itsSelector == #doRecolor:with:
+ ifTrue: [^ Preferences propertySheetFromHalo
+ ifTrue: ['Open a property sheet.']
+ ifFalse: ['Change color']].
+ itsSelector == #mouseDownInDimissHandle:with:
+ ifTrue: [^ TrashCanMorph preserveTrash
+ ifTrue: ['Move to trash']
+ ifFalse: ['Remove from screen']].
+ #(#(#addFullHandles 'More halo handles') #(#addSimpleHandles 'Fewer halo handles') #(#chooseEmphasisOrAlignment 'Emphasis & alignment') #(#chooseFont 'Change font') #(#chooseNewGraphicFromHalo 'Choose a new graphic') #(#chooseStyle 'Change style') #(#dismiss 'Remove') #(#doDebug:with: 'Debug') #(#doDirection:with: 'Choose forward direction') #(#doDup:with: 'Duplicate') #(#doMakeSibling:with: 'Make a sibling') #(#doMenu:with: 'Menu') #(#doGrab:with: 'Pick up') #(#editButtonsScript 'See the script for this button') #(#editDrawing 'Repaint') #(#doDupOrMakeSibling:with: 'Duplicate (press shift to make a sibling)') #(#doMakeSiblingOrDup:with: 'Make a sibling (press shift to make simple duplicate)') #(#makeNascentScript 'Make a scratch script') #(#makeNewDrawingWithin 'Paint new object') #(#mouseDownInCollapseHandle:with: 'Collapse') #(#mouseDownOnHelpHandle: 'Help') #(#openViewerForArgument 'Open a Viewer for me. Press shift for a snapshot.') #(#openViewerForTarget:with: 'Open a Viewer for me. Press shift for a snapshot.') #(#paintBackground 'Paint background') #(#prepareToTrackCenterOfRotation:with: 'Move object or set center of rotation') #(#presentViewMenu 'Present the Viewing menu') #(#startDrag:with: 'Move') #(#startGrow:with: 'Change size') #(#startRot:with: 'Rotate') #(#startScale:with: 'Change scale') #(#tearOffTile 'Make a tile representing this object') #(#tearOffTileForTarget:with: 'Make a tile representing this object') #(#trackCenterOfRotation:with: 'Set center of rotation') )
+ do: [:pair | itsSelector == pair first
+ ifTrue: [^ pair last]].
+ ^ 'unknown halo handle'translated!
Item was added:
+ ----- Method: Morph>>balloonMorphClass (in category 'halos and balloon help') -----
+ balloonMorphClass
+
+ ^ NewBalloonMorph useNewBalloonMorph
+ ifTrue: [NewBalloonMorph]
+ ifFalse: [BalloonMorph]!
Item was added:
+ ----- Method: Morph>>balloonText (in category 'accessing') -----
+ balloonText
+ "Answer balloon help text or nil, if no help is available.
+ NB: subclasses may override such that they programatically
+ construct the text, for economy's sake, such as model phrases in
+ a Viewer"
+
+ | result |
+ extension ifNil: [^nil].
+
+ extension balloonText
+ ifNotNil: [:balloonText | result := balloonText]
+ ifNil: [extension balloonTextSelector
+ ifNotNil: [:balloonSelector |
+ result := ScriptingSystem helpStringOrNilFor: balloonSelector.
+ (result isNil and: [balloonSelector == #methodComment])
+ ifTrue: [result := self methodCommentAsBalloonHelp].
+ ((result isNil and: [balloonSelector numArgs = 0])
+ and: [self respondsTo: balloonSelector])
+ ifTrue: [result := self perform: balloonSelector]]].
+ ^ result!
Item was added:
+ ----- Method: Morph>>balloonText: (in category 'accessing') -----
+ balloonText: aString
+
+ self assureExtension balloonText: aString.!
Item was added:
+ ----- Method: Morph>>balloonTextSelector (in category 'accessing') -----
+ balloonTextSelector
+ "Answer balloon text selector item in the extension, nil if none"
+ ^ extension ifNotNil: [extension balloonTextSelector]!
Item was added:
+ ----- Method: Morph>>balloonTextSelector: (in category 'accessing') -----
+ balloonTextSelector: aSelector
+ "change the receiver's balloonTextSelector"
+ self assureExtension balloonTextSelector: aSelector!
Item was added:
+ ----- Method: Morph>>basicInitialize (in category 'initialization') -----
+ basicInitialize
+ "Do basic generic initialization of the instance variables:
+ Set up the receiver, created by a #basicNew and now ready to
+ be initialized, by placing initial values in the instance variables
+ as appropriate"
+ owner := nil.
+ submorphs := Array empty.
+ bounds := self defaultBounds.
+ color := self defaultColor!
Item was added:
+ ----- Method: Morph>>beFlap: (in category 'accessing') -----
+ beFlap: aBool
+ "Mark the receiver with the #flap property, or unmark it"
+
+ aBool
+ ifTrue:
+ [self setProperty: #flap toValue: true.
+ self hResizing: #rigid.
+ self vResizing: #rigid]
+ ifFalse:
+ [self removeProperty: #flap]!
Item was added:
+ ----- Method: Morph>>beSticky (in category 'accessing') -----
+ beSticky
+ "make the receiver sticky"
+ self assureExtension sticky: true!
Item was added:
+ ----- Method: Morph>>beThisWorldsModel (in category 'meta-actions') -----
+ beThisWorldsModel
+
+ self world setModel: self.
+ self model: nil slotName: nil. "A world's model cannot have another model"!
Item was added:
+ ----- Method: Morph>>beUnsticky (in category 'accessing') -----
+ beUnsticky
+ "If the receiver is marked as sticky, make it now be unsticky"
+ extension ifNotNil: [extension sticky: false]!
Item was added:
+ ----- Method: Morph>>becomeModal (in category 'user interface') -----
+ becomeModal
+ self currentWorld
+ ifNotNil: [self currentWorld modalWindow: self]!
Item was added:
+ ----- Method: Morph>>blueButtonDown: (in category 'meta-actions') -----
+ blueButtonDown: anEvent
+ "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph."
+ | h tfm doNotDrag |
+ h := anEvent hand halo.
+ "Prevent wrap around halo transfers originating from throwing the event back in"
+ doNotDrag := false.
+ h ifNotNil:[
+ (h innerTarget == self) ifTrue:[doNotDrag := true].
+ (h innerTarget hasOwner: self) ifTrue:[doNotDrag := true].
+ (self hasOwner: h target) ifTrue:[doNotDrag := true]].
+
+ tfm := (self transformedFrom: nil) inverseTransformation.
+
+ "cmd-drag on flexed morphs works better this way"
+ h := self addHalo: (anEvent transformedBy: tfm).
+ h ifNil: [^ self].
+ doNotDrag ifTrue:[^self].
+ "Initiate drag transition if requested"
+ anEvent hand
+ waitForClicksOrDrag: h
+ event: (anEvent transformedBy: tfm)
+ selectors: { nil. nil. nil. #dragTarget:. }
+ threshold: HandMorph dragThreshold.
+ "Pass focus explicitly here"
+ anEvent hand newMouseFocus: h.!
Item was added:
+ ----- Method: Morph>>blueButtonUp: (in category 'meta-actions') -----
+ blueButtonUp: anEvent
+ "Ignored. Theoretically we should never get here since control is transferred to the halo on #blueButtonDown: but subclasses may implement this differently."!
Item was added:
+ ----- Method: Morph>>borderColor (in category 'accessing') -----
+ borderColor
+ ^self borderStyle color!
Item was added:
+ ----- Method: Morph>>borderColor: (in category 'accessing') -----
+ borderColor: aColorOrSymbolOrNil
+ "Unfortunately, the argument to borderColor could be more than just a color.
+ It could also be a symbol, in which case it is to be interpreted as a style identifier.
+ But I might not be able to draw that kind of border, so it may have to be ignored.
+ Or it could be nil, in which case I should revert to the default border."
+
+ | style newStyle |
+ style := self borderStyle.
+ style baseColor = aColorOrSymbolOrNil
+ ifTrue: [^ self].
+
+ aColorOrSymbolOrNil isColor
+ ifTrue: [style style = #none "default border?"
+ ifTrue: [self borderStyle: (SimpleBorder width: 0 color: aColorOrSymbolOrNil)]
+ ifFalse: [style baseColor: aColorOrSymbolOrNil.
+ self changed].
+ ^ self].
+
+ self
+ borderStyle: ( ({ nil. #none } includes: aColorOrSymbolOrNil)
+ ifTrue: [BorderStyle default]
+ ifFalse: [ "a symbol"
+ self doesBevels ifFalse: [ ^self ].
+ newStyle := (BorderStyle perform: aColorOrSymbolOrNil)
+ color: style color;
+ width: style width;
+ yourself.
+ (self canDrawBorder: newStyle)
+ ifTrue: [newStyle]
+ ifFalse: [style]])!
Item was added:
+ ----- Method: Morph>>borderStyle (in category 'accessing') -----
+ borderStyle
+ ^(self valueOfProperty: #borderStyle ifAbsent:[BorderStyle default]) trackColorFrom: self!
Item was added:
+ ----- Method: Morph>>borderStyle: (in category 'accessing') -----
+ borderStyle: newStyle
+ newStyle = self borderStyle ifFalse:[
+ (self canDrawBorder: newStyle) ifFalse:[
+ "Replace the suggested border with a simple one"
+ ^self borderStyle: (BorderStyle width: newStyle width color: (newStyle trackColorFrom: self) color)].
+ self setProperty: #borderStyle toValue: newStyle.
+ self changed].!
Item was added:
+ ----- Method: Morph>>borderStyleForSymbol: (in category 'accessing') -----
+ borderStyleForSymbol: aStyleSymbol
+ "Answer a suitable BorderStyle for me of the type represented by a given symbol"
+
+ | aStyle existing |
+ aStyle := BorderStyle borderStyleForSymbol: aStyleSymbol asSymbol.
+ aStyle ifNil: [self error: 'bad style'].
+ existing := self borderStyle.
+ aStyle width: existing width;
+ baseColor: existing baseColor.
+ ^ (self canDrawBorder: aStyle)
+ ifTrue:
+ [aStyle]
+ ifFalse:
+ [nil]!
Item was added:
+ ----- Method: Morph>>borderWidth (in category 'accessing') -----
+ borderWidth
+ ^self borderStyle width!
Item was added:
+ ----- Method: Morph>>borderWidth: (in category 'accessing') -----
+ borderWidth: aNumber
+ | style |
+ style := self borderStyle.
+ style width = aNumber ifTrue: [ ^self ].
+
+ style style = #none
+ ifTrue: [ self borderStyle: (SimpleBorder width: aNumber color: Color transparent) ]
+ ifFalse: [ style width: aNumber. self changed ].
+ !
Item was added:
+ ----- Method: Morph>>borderWidthForRounding (in category 'accessing') -----
+ borderWidthForRounding
+
+ ^ self borderWidth!
Item was added:
+ ----- Method: Morph>>bottom (in category 'geometry') -----
+ bottom
+ " Return the y-coordinate of my bottom side "
+
+ ^ bounds bottom!
Item was added:
+ ----- Method: Morph>>bottom: (in category 'geometry') -----
+ bottom: aNumber
+ " Move me so that my bottom is at the y-coordinate aNumber. My extent (width & height) are unchanged "
+
+ self position: (bounds left @ (aNumber - self height))!
Item was added:
+ ----- Method: Morph>>bottomCenter (in category 'geometry') -----
+ bottomCenter
+
+ ^ bounds bottomCenter!
Item was added:
+ ----- Method: Morph>>bottomLeft (in category 'geometry') -----
+ bottomLeft
+
+ ^ bounds bottomLeft!
Item was added:
+ ----- Method: Morph>>bottomLeft: (in category 'geometry') -----
+ bottomLeft: aPoint
+ " Move me so that my bottom left corner is at aPoint. My extent (width & height) are unchanged "
+
+ self position: ((aPoint x) @ (aPoint y - self height)).
+ !
Item was added:
+ ----- Method: Morph>>bottomRight (in category 'geometry') -----
+ bottomRight
+
+ ^ bounds bottomRight!
Item was added:
+ ----- Method: Morph>>bottomRight: (in category 'geometry') -----
+ bottomRight: aPoint
+ " Move me so that my bottom right corner is at aPoint. My extent (width & height) are unchanged "
+
+ self position: ((aPoint x - bounds width) @ (aPoint y - self height))
+ !
Item was added:
+ ----- Method: Morph>>boundingBoxOfSubmorphs (in category 'drawing') -----
+ boundingBoxOfSubmorphs
+ | aBox |
+ aBox := bounds origin extent: self minimumExtent. "so won't end up with something empty"
+ submorphs do:
+ [:m | m visible ifTrue: [aBox := aBox quickMerge: m fullBounds]].
+ ^ aBox
+ !
Item was added:
+ ----- Method: Morph>>bounds (in category 'geometry') -----
+ bounds
+ "Return the bounds of this morph."
+ "Note: It is best not to override this method because many methods in Morph and its subclasses use the instance variable directly rather than 'self bounds'. Instead, subclasses should be sure that the bounds instance variable is correct."
+
+ ^ bounds
+ !
Item was added:
+ ----- Method: Morph>>bounds: (in category 'geometry') -----
+ bounds: newBounds
+ | oldExtent newExtent |
+ oldExtent := self extent.
+ newExtent := newBounds extent.
+ (oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[
+ "We're growing. First move then resize."
+ self position: newBounds topLeft; extent: newExtent.
+ ] ifFalse:[
+ "We're shrinking. First resize then move."
+ self extent: newExtent; position: newBounds topLeft.
+ ].!
Item was added:
+ ----- Method: Morph>>bounds:from: (in category 'geometry') -----
+ bounds: aRectangle from: referenceMorph
+ "Return the receiver's bounds as seen by aMorphs coordinate frame"
+ owner ifNil: [^ aRectangle].
+ ^(owner transformFrom: referenceMorph) globalBoundsToLocal: aRectangle
+ !
Item was added:
+ ----- Method: Morph>>bounds:in: (in category 'geometry') -----
+ bounds: aRectangle in: referenceMorph
+ "Return the receiver's bounds as seen by aMorphs coordinate frame"
+ owner ifNil: [^ aRectangle].
+ ^(owner transformFrom: referenceMorph) localBoundsToGlobal: aRectangle
+ !
Item was added:
+ ----- Method: Morph>>boundsForBalloon (in category 'halos and balloon help') -----
+ boundsForBalloon
+
+ "some morphs have bounds that are way too big"
+ ^self boundsInWorld!
Item was added:
+ ----- Method: Morph>>boundsIn: (in category 'geometry') -----
+ boundsIn: referenceMorph
+ "Return the receiver's bounds as seen by aMorphs coordinate frame"
+ ^self bounds: self bounds in: referenceMorph!
Item was added:
+ ----- Method: Morph>>boundsInWorld (in category 'geometry') -----
+ boundsInWorld
+ ^self bounds: self bounds in: self world!
Item was added:
+ ----- Method: Morph>>boundsWithinCorners (in category 'drawing') -----
+ boundsWithinCorners
+ "Return a single sub-rectangle that lies entirely inside corners
+ that are made by me.
+ Used to identify large regions of window that do not need to be redrawn."
+
+ ^ self wantsRoundedCorners
+ ifTrue: [self bounds insetBy: 0 at self class preferredCornerRadius]
+ ifFalse: [self bounds]
+ !
Item was added:
+ ----- Method: Morph>>bringAllSiblingsToMe: (in category 'meta-actions') -----
+ bringAllSiblingsToMe: evt
+ "bring all siblings of the receiver's player found in the same container to the receiver's location."
+
+ | aPlayer aPosition aContainer |
+ (aPlayer := self topRendererOrSelf player) belongsToUniClass ifFalse: [self error: 'not uniclass'].
+ aPosition := self topRendererOrSelf position.
+ aContainer := self topRendererOrSelf owner.
+ (aPlayer class allInstances copyWithout: aPlayer) do:
+ [:each |
+ (aContainer submorphs includes: each costume) ifTrue:
+ [each costume position: aPosition]]!
Item was added:
+ ----- Method: Morph>>buildDebugMenu: (in category 'debug and other') -----
+ buildDebugMenu: aHand
+ "Answer a debugging menu for the receiver. The hand argument is seemingly historical and plays no role presently"
+
+ | aMenu aPlayer |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu addStayUpItem.
+ (self hasProperty: #errorOnDraw) ifTrue:
+ [aMenu add: 'start drawing again' translated action: #resumeAfterDrawError.
+ aMenu addLine].
+ (self hasProperty: #errorOnStep) ifTrue:
+ [aMenu add: 'start stepping again' translated action: #resumeAfterStepError.
+ aMenu addLine].
+
+ aMenu add: 'inspect morph' translated action: #inspectInMorphic:.
+ aMenu add: 'inspect owner chain' translated action: #inspectOwnerChain.
+ Smalltalk isMorphic ifFalse:
+ [aMenu add: 'inspect morph (in MVC)' translated action: #inspect].
+
+ self isMorphicModel ifTrue:
+ [aMenu add: 'inspect model' translated target: self model action: #inspect].
+ (aPlayer := self player) ifNotNil:
+ [aMenu add: 'inspect player' translated target: aPlayer action: #inspect].
+
+ aMenu add: 'explore morph' translated target: self selector: #exploreInMorphic:.
+
+ aMenu addLine.
+ aPlayer ifNotNil:
+ [ aMenu add: 'viewer for Player' translated target: self player action: #beViewed.
+ aMenu balloonTextForLastItem: 'Opens a viewer on my Player -- this is the same thing you get if you click on the cyan "View" halo handle' translated ].
+
+ aMenu add: 'viewer for Morph' translated target: self action: #viewMorphDirectly.
+ aMenu balloonTextForLastItem: 'Opens a Viewer on this Morph, rather than on its Player' translated.
+ aMenu addLine.
+
+ aPlayer ifNotNil:
+ [aPlayer class isUniClass ifTrue: [
+ aMenu add: 'browse player class' translated target: aPlayer action: #browseHierarchy]].
+ aMenu add: 'browse morph class' translated target: self selector: #browseHierarchy.
+ (self isMorphicModel)
+ ifTrue: [aMenu
+ add: 'browse model class'
+ target: self model
+ selector: #browseHierarchy].
+ aMenu addLine.
+
+ self addViewingItemsTo: aMenu.
+ aMenu
+ add: 'make own subclass' translated action: #subclassMorph;
+ add: 'save morph in file' translated action: #saveOnFile;
+ addLine;
+ add: 'call #tempCommand' translated action: #tempCommand;
+ add: 'define #tempCommand' translated action: #defineTempCommand;
+ addLine;
+
+ add: 'control-menu...' translated target: self selector: #invokeMetaMenu:;
+ add: 'edit balloon help' translated action: #editBalloonHelpText.
+
+ ^ aMenu!
Item was added:
+ ----- Method: Morph>>buildHandleMenu: (in category 'meta-actions') -----
+ buildHandleMenu: aHand
+ "Build the morph menu for the given morph's halo's menu handle. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph. This method allows the morph to decide which items should be included in the hand's section of the menu."
+
+ | menu |
+
+ (Preferences generalizedYellowButtonMenu
+ and: [Preferences noviceMode])
+ ifTrue: [^ self buildYellowButtonMenu: aHand].
+
+ menu := MenuMorph new defaultTarget: self.
+ menu addStayUpItem.
+ menu addLine.
+ self addStandardHaloMenuItemsTo: menu hand: aHand.
+ menu defaultTarget: aHand.
+ self addAddHandMenuItemsForHalo: menu hand: aHand.
+ menu defaultTarget: self.
+ self addCustomHaloMenuItems: menu hand: aHand.
+ menu defaultTarget: aHand.
+ ^ menu
+ !
Item was added:
+ ----- Method: Morph>>buildMetaMenu: (in category 'meta-actions') -----
+ buildMetaMenu: evt
+ "Build the morph menu. This menu has two sections. The first section contains commands that are handled by the hand; the second contains commands handled by the argument morph."
+ | menu |
+ menu := MenuMorph new defaultTarget: self.
+ menu addStayUpItem.
+ menu add: 'grab' translated action: #grabMorph:.
+ menu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:.
+ self maybeAddCollapseItemTo: menu.
+ menu add: 'delete' translated action: #dismissMorph:.
+ menu addLine.
+ menu add: 'copy text' translated action: #clipText.
+ menu add: 'copy Postscript' translated action: #clipPostscript.
+ menu add: 'print Postscript to file...' translated action: #printPSToFile.
+ menu addLine.
+ menu add: 'go behind' translated action: #goBehind.
+ menu add: 'add halo' translated action: #addHalo:.
+ menu add: 'duplicate' translated action: #maybeDuplicateMorph:.
+
+ self addEmbeddingMenuItemsTo: menu hand: evt hand.
+
+ menu add: 'resize' translated action: #resizeMorph:.
+ "Give the argument control over what should be done about fill styles"
+ self addFillStyleMenuItems: menu hand: evt hand.
+ self addDropShadowMenuItems: menu hand: evt hand.
+ self addLayoutMenuItems: menu hand: evt hand.
+ menu addUpdating: #hasClipSubmorphsString target: self selector: #changeClipSubmorphs argumentList: #().
+ menu addLine.
+
+ (self morphsAt: evt position) size > 1 ifTrue:
+ [menu add: 'submorphs...' translated
+ target: self
+ selector: #invokeMetaMenuAt:event:
+ argument: evt position].
+ menu addLine.
+ menu add: 'inspect' translated selector: #inspectAt:event: argument: evt position.
+ menu add: 'explore' translated action: #explore.
+ menu add: 'browse hierarchy' translated action: #browseHierarchy.
+ menu add: 'make own subclass' translated action: #subclassMorph.
+ menu addLine.
+ (self isMorphicModel) ifTrue:
+ [menu add: 'save morph as prototype' translated action: #saveAsPrototype.
+ (self ~~ self world modelOrNil) ifTrue:
+ [menu add: 'become this world''s model' translated action: #beThisWorldsModel]].
+ menu add: 'save morph in file' translated action: #saveOnFile.
+ (self hasProperty: #resourceFilePath)
+ ifTrue: [((self valueOfProperty: #resourceFilePath) endsWith: '.morph')
+ ifTrue: [menu add: 'save as resource' translated action: #saveAsResource].
+ menu add: 'update from resource' translated action: #updateFromResource]
+ ifFalse: [menu add: 'attach to resource' translated action: #attachToResource].
+ menu add: 'show actions' translated action: #showActions.
+ menu addLine.
+ self addDebuggingItemsTo: menu hand: evt hand.
+
+ self addCustomMenuItems: menu hand: evt hand.
+ ^ menu
+ !
Item was added:
+ ----- Method: Morph>>buildYellowButtonMenu: (in category 'menu') -----
+ buildYellowButtonMenu: aHand
+ "build the morph menu for the yellow button"
+ | menu |
+ menu := MenuMorph new defaultTarget: self.
+ self addNestedYellowButtonItemsTo: menu event: ActiveEvent.
+ MenuIcons decorateMenu: menu.
+ ^ menu!
Item was added:
+ ----- Method: Morph>>canBeEncroached (in category 'private') -----
+ canBeEncroached
+ "Support for the #smartHorizontalSplitters preference."
+ ^ true!
Item was added:
+ ----- Method: Morph>>canDrawAtHigherResolution (in category 'testing') -----
+ canDrawAtHigherResolution
+
+ ^false!
Item was added:
+ ----- Method: Morph>>canDrawBorder: (in category 'testing') -----
+ canDrawBorder: aBorderStyle
+ "Return true if the receiver can be drawn with the given border style."
+ ^true!
Item was added:
+ ----- Method: Morph>>canHaveFillStyles (in category 'visual properties') -----
+ canHaveFillStyles
+ "Return true if the receiver can have general fill styles; not just colors.
+ This method is for gradually converting old morphs."
+ ^self class == Morph "no subclasses"!
Item was added:
+ ----- Method: Morph>>cellInset (in category 'layout-properties') -----
+ cellInset
+ "Layout specific. This property specifies an extra inset for each cell in the layout."
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[0] ifNotNil:[props cellInset].!
Item was added:
+ ----- Method: Morph>>cellInset: (in category 'layout-properties') -----
+ cellInset: aNumber
+ "Layout specific. This property specifies an extra inset for each cell in the layout."
+ self assureTableProperties cellInset: aNumber.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>cellPositioning (in category 'layout-properties') -----
+ cellPositioning
+ "Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are:
+ #topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center
+ which align the receiver's bounds with the cell at the given point."
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#center] ifNotNil:[props cellPositioning].!
Item was added:
+ ----- Method: Morph>>cellPositioning: (in category 'layout-properties') -----
+ cellPositioning: aSymbol
+ "Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are:
+ #topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center
+ which align the receiver's bounds with the cell at the given point."
+ self assureTableProperties cellPositioning: aSymbol.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>cellPositioningString: (in category 'layout-properties') -----
+ cellPositioningString: aSymbol
+ ^self layoutMenuPropertyString: aSymbol from: self cellPositioning!
Item was added:
+ ----- Method: Morph>>cellSpacing (in category 'layout-properties') -----
+ cellSpacing
+ "Layout specific. This property describes how the cell size for each element in a list should be computed.
+ #globalRect - globally equal rectangular cells
+ #globalSquare - globally equal square cells
+ #localRect - locally (e.g., per row/column) equal rectangular cells
+ #localSquare - locally (e.g., per row/column) equal square cells
+ #none - cells are sized based on available row/column constraints
+ "
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#none] ifNotNil:[props cellSpacing].!
Item was added:
+ ----- Method: Morph>>cellSpacing: (in category 'layout-properties') -----
+ cellSpacing: aSymbol
+ "Layout specific. This property describes how the cell size for each element in a list should be computed.
+ #globalRect - globally equal rectangular cells
+ #globalSquare - globally equal square cells
+ #localRect - locally (e.g., per row/column) equal rectangular cells
+ #localSquare - locally (e.g., per row/column) equal square cells
+ #none - cells are sized based on available row/column constraints
+ "
+ self assureTableProperties cellSpacing: aSymbol.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>cellSpacingString: (in category 'layout-properties') -----
+ cellSpacingString: aSymbol
+ ^self layoutMenuPropertyString: aSymbol from: self cellSpacing!
Item was added:
+ ----- Method: Morph>>center (in category 'geometry') -----
+ center
+
+ ^ bounds center!
Item was added:
+ ----- Method: Morph>>center: (in category 'geometry') -----
+ center: aPoint
+ self position: (aPoint - (self extent // 2))!
Item was added:
+ ----- Method: Morph>>changeCellInset: (in category 'layout-menu') -----
+ changeCellInset: evt
+ | handle |
+ handle := HandleMorph new forEachPointDo:[:newPoint |
+ self cellInset: (newPoint - evt cursorPoint) asIntegerPoint // 5].
+ evt hand attachMorph: handle.
+ handle startStepping.
+ !
Item was added:
+ ----- Method: Morph>>changeClipLayoutCells (in category 'layout-menu') -----
+ changeClipLayoutCells
+ self invalidRect: self fullBounds.
+ self clipLayoutCells: self clipLayoutCells not.
+ self invalidRect: self fullBounds.!
Item was added:
+ ----- Method: Morph>>changeClipSubmorphs (in category 'drawing') -----
+ changeClipSubmorphs
+ self clipSubmorphs: self clipSubmorphs not.!
Item was added:
+ ----- Method: Morph>>changeColor (in category 'menus') -----
+ changeColor
+ "Change the color of the receiver -- triggered, e.g. from a menu"
+ NewColorPickerMorph useIt
+ ifTrue: [ (NewColorPickerMorph on: self) openNear: self fullBoundsInWorld ]
+ ifFalse:
+ [ ColorPickerMorph new
+ choseModalityFromPreference ;
+ sourceHand: self activeHand ;
+ target: self ;
+ selector: #fillStyle: ;
+ originalColor: self color ;
+
+ putUpFor: self
+ near: self fullBoundsInWorld ]!
Item was added:
+ ----- Method: Morph>>changeColorTarget:selector:originalColor:hand: (in category 'meta-actions') -----
+ changeColorTarget: anObject selector: aSymbol originalColor: aColor hand: aHand
+ "Put up a color picker for changing some kind of color. May be modal or modeless, depending on #modalColorPickers setting"
+ | desiredLoc |
+ self flag: #arNote.
+ "Simplify this due to anObject == self for almost all cases"
+ desiredLoc := anObject isMorph
+ ifTrue:
+ [ Rectangle
+ center: self position
+ extent: 20 ]
+ ifFalse:
+ [ anObject == self world
+ ifTrue: [ anObject viewBox bottomLeft + (20 @ -20) extent: 200 ]
+ ifFalse: [ anObject fullBoundsInWorld ] ].
+ ^ NewColorPickerMorph useIt
+ ifTrue:
+ [ (NewColorPickerMorph
+ on: anObject
+ originalColor: aColor
+ setColorSelector: aSymbol) openNear: desiredLoc ]
+ ifFalse:
+ [ ColorPickerMorph new
+ choseModalityFromPreference ;
+ sourceHand: aHand ;
+ target: anObject ;
+ selector: aSymbol ;
+ originalColor: aColor ;
+
+ putUpFor: anObject
+ near: desiredLoc ;
+ yourself ]!
Item was added:
+ ----- Method: Morph>>changeDirectionHandles (in category 'menus') -----
+ changeDirectionHandles
+ ^self wantsDirectionHandles: self wantsDirectionHandles not!
Item was added:
+ ----- Method: Morph>>changeDisableTableLayout (in category 'layout-menu') -----
+ changeDisableTableLayout
+ self disableTableLayout: self disableTableLayout not.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>changeDocumentAnchor (in category 'text-anchor') -----
+ changeDocumentAnchor
+ "Change the anchor from/to document anchoring"
+
+ | newType |
+ newType := self textAnchorType == #document
+ ifTrue: [#paragraph]
+ ifFalse: [ #document].
+ owner isTextMorph
+ ifTrue:
+ [owner
+ anchorMorph: self
+ at: self position
+ type: newType]!
Item was added:
+ ----- Method: Morph>>changeDragAndDrop (in category 'menus') -----
+ changeDragAndDrop
+ ^self enableDragNDrop: self dragNDropEnabled not!
Item was added:
+ ----- Method: Morph>>changeInlineAnchor (in category 'text-anchor') -----
+ changeInlineAnchor
+ "Change the anchor from/to line anchoring"
+
+ | newType |
+ newType := self textAnchorType == #inline
+ ifTrue: [#paragraph]
+ ifFalse: [#inline].
+ owner isTextMorph
+ ifTrue:
+ [owner
+ anchorMorph: self
+ at: self position
+ type: newType]!
Item was added:
+ ----- Method: Morph>>changeLayoutInset: (in category 'layout-menu') -----
+ changeLayoutInset: evt
+ | handle |
+ handle := HandleMorph new forEachPointDo:[:newPoint |
+ self layoutInset: (newPoint - evt cursorPoint) asIntegerPoint // 5].
+ evt hand attachMorph: handle.
+ handle startStepping.
+ !
Item was added:
+ ----- Method: Morph>>changeListDirection: (in category 'layout-menu') -----
+ changeListDirection: aSymbol
+ | listDir wrapDir |
+ self listDirection: aSymbol.
+ (self wrapDirection == #none) ifTrue:[^self].
+ "otherwise automatically keep a valid table layout"
+ listDir := self listDirection.
+ wrapDir := self wrapDirection.
+ (listDir == #leftToRight or:[listDir == #rightToLeft]) ifTrue:[
+ wrapDir == #leftToRight ifTrue:[^self wrapDirection: #topToBottom].
+ wrapDir == #rightToLeft ifTrue:[^self wrapDirection: #bottomToTop].
+ ] ifFalse:[
+ wrapDir == #topToBottom ifTrue:[^self wrapDirection: #leftToRight].
+ wrapDir == #bottomToTop ifTrue:[^self wrapDirection: #rightToLeft].
+ ].
+ !
Item was added:
+ ----- Method: Morph>>changeMaxCellSize: (in category 'layout-menu') -----
+ changeMaxCellSize: evt
+ | handle |
+ handle := HandleMorph new forEachPointDo:[:newPoint |
+ self maxCellSize: (newPoint - evt cursorPoint) asIntegerPoint].
+ evt hand attachMorph: handle.
+ handle startStepping.
+ !
Item was added:
+ ----- Method: Morph>>changeMinCellSize: (in category 'layout-menu') -----
+ changeMinCellSize: evt
+ | handle |
+ handle := HandleMorph new forEachPointDo:[:newPoint |
+ self minCellSize: (newPoint - evt cursorPoint) asIntegerPoint].
+ evt hand attachMorph: handle.
+ handle startStepping.
+ !
Item was added:
+ ----- Method: Morph>>changeNoLayout (in category 'layout-menu') -----
+ changeNoLayout
+ self layoutPolicy ifNil:[^self]. "already no layout"
+ self layoutPolicy: nil.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>changeParagraphAnchor (in category 'text-anchor') -----
+ changeParagraphAnchor
+ "Change the anchor from/to paragraph anchoring"
+
+ | newType |
+ newType := self textAnchorType == #paragraph
+ ifTrue: [#document]
+ ifFalse: [#paragraph].
+ owner isTextMorph
+ ifTrue:
+ [owner
+ anchorMorph: self
+ at: self position
+ type: newType]!
Item was added:
+ ----- Method: Morph>>changeProportionalLayout (in category 'layout-menu') -----
+ changeProportionalLayout
+ | layout |
+ ((layout := self layoutPolicy) notNil and:[layout isProportionalLayout])
+ ifTrue:[^self]. "already proportional layout"
+ self layoutPolicy: ProportionalLayout new.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>changeReverseCells (in category 'layout-menu') -----
+ changeReverseCells
+ self reverseTableCells: self reverseTableCells not.!
Item was added:
+ ----- Method: Morph>>changeRubberBandCells (in category 'layout-menu') -----
+ changeRubberBandCells
+ self rubberBandCells: self rubberBandCells not.!
Item was added:
+ ----- Method: Morph>>changeShadowColor (in category 'drop shadows') -----
+ changeShadowColor
+ "Change the shadow color of the receiver -- triggered, e.g. from a menu"
+ NewColorPickerMorph useIt
+ ifTrue:
+ [ (NewColorPickerMorph
+ on: self
+ originalColor: self shadowColor
+ setColorSelector: #shadowColor:) openNearMorph: self ]
+ ifFalse:
+ [ ColorPickerMorph new
+ choseModalityFromPreference ;
+ sourceHand: self activeHand ;
+ target: self ;
+ selector: #shadowColor: ;
+ originalColor: self shadowColor ;
+
+ putUpFor: self
+ near: self fullBoundsInWorld ]!
Item was added:
+ ----- Method: Morph>>changeTableLayout (in category 'layout-menu') -----
+ changeTableLayout
+ | layout |
+ ((layout := self layoutPolicy) notNil and:[layout isTableLayout])
+ ifTrue:[^self]. "already table layout"
+ self layoutPolicy: TableLayout new.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>changed (in category 'updating') -----
+ changed
+ "Report that the area occupied by this morph should be redrawn."
+ ^fullBounds
+ ifNil:[self invalidRect: self outerBounds]
+ ifNotNil:[self invalidRect: fullBounds]!
Item was added:
+ ----- Method: Morph>>chooseNewGraphic (in category 'menus') -----
+ chooseNewGraphic
+ "Used by any morph that can be represented by a graphic"
+ self chooseNewGraphicCoexisting: false
+ !
Item was added:
+ ----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') -----
+ chooseNewGraphicCoexisting: aBoolean
+ "Allow the user to choose a different form for her form-based morph"
+ | replacee aGraphicalMenu |
+ aGraphicalMenu := GraphicalMenu new
+ initializeFor: self
+ withForms: self reasonableForms
+ coexist: aBoolean.
+ aBoolean
+ ifTrue: [self primaryHand attachMorph: aGraphicalMenu]
+ ifFalse: [replacee := self topRendererOrSelf.
+ replacee owner replaceSubmorph: replacee by: aGraphicalMenu]!
Item was added:
+ ----- Method: Morph>>chooseNewGraphicFromHalo (in category 'menus') -----
+ chooseNewGraphicFromHalo
+ "Allow the user to select a changed graphic to replace the one in the receiver"
+
+ self currentWorld abandonAllHalos.
+ self chooseNewGraphicCoexisting: true
+ !
Item was added:
+ ----- Method: Morph>>clearArea (in category 'accessing') -----
+ clearArea
+ "Answer the clear area of the receiver. It means the area free
+ of docking bars."
+ | visTop visBottom visLeft visRight |
+
+ visTop := self top.
+ visBottom := self bottom.
+ visLeft := self left.
+ visRight := self right.
+
+ self dockingBars
+ do: [:each |
+ (each isAdheringToTop and: [each bottom > visTop])
+ ifTrue: [visTop := each bottom].
+
+ (each isAdheringToBottom and: [each top < visBottom])
+ ifTrue: [visBottom := each top].
+
+ (each isAdheringToLeft and: [each right > visLeft])
+ ifTrue: [visLeft := each right].
+
+ (each isAdheringToRight and: [each left < visRight])
+ ifTrue: [visRight := each left]
+ ].
+
+ ^ Rectangle
+ left: visLeft
+ right: visRight
+ top: visTop
+ bottom: visBottom
+ !
Item was added:
+ ----- Method: Morph>>click (in category 'event handling') -----
+ click
+ "Pretend the user clicked on me."
+
+ (self handlesMouseDown: nil) ifTrue: [
+ self mouseDown: nil.
+ self mouseUp: nil].!
Item was added:
+ ----- Method: Morph>>click: (in category 'event handling') -----
+ click: evt
+ "Handle a single-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing.
+ LC 2/14/2000 08:32 - added: EventHandler notification"
+
+ self eventHandler ifNotNil:
+ [self eventHandler click: evt fromMorph: self].!
Item was added:
+ ----- Method: Morph>>clipLayoutCells (in category 'drawing') -----
+ clipLayoutCells
+ "Drawing/layout specific. If this property is set, clip the
+ submorphs of the receiver by its cell bounds."
+ ^ self
+ valueOfProperty: #clipLayoutCells
+ ifAbsent: [false]!
Item was added:
+ ----- Method: Morph>>clipLayoutCells: (in category 'drawing') -----
+ clipLayoutCells: aBool
+ "Drawing/layout specific. If this property is set, clip the submorphs of the receiver by its cell bounds."
+ aBool == false
+ ifTrue:[self removeProperty: #clipLayoutCells]
+ ifFalse:[self setProperty: #clipLayoutCells toValue: aBool].
+ self changed.!
Item was added:
+ ----- Method: Morph>>clipPostscript (in category '*morphic-Postscript Canvases') -----
+ clipPostscript
+ ^Clipboard clipboardText: self asPostscript.
+
+ !
Item was added:
+ ----- Method: Morph>>clipSubmorphs (in category 'drawing') -----
+ clipSubmorphs
+ "Drawing specific. If this property is set, clip the receiver's
+ submorphs to the receiver's clipping bounds."
+
+ extension ifNil: [^false].
+ ^ self
+ valueOfProperty: #clipSubmorphs
+ ifAbsent: [false]!
Item was added:
+ ----- Method: Morph>>clipSubmorphs: (in category 'drawing') -----
+ clipSubmorphs: aBool
+ "Drawing specific. If this property is set, clip the receiver's submorphs to the receiver's clipping bounds."
+ self invalidRect: self fullBounds.
+ aBool == false
+ ifTrue:[self removeProperty: #clipSubmorphs]
+ ifFalse:[self setProperty: #clipSubmorphs toValue: aBool].
+ self invalidRect: self fullBounds.!
Item was added:
+ ----- Method: Morph>>clipText (in category 'printing') -----
+ clipText
+ "Copy the text in the receiver or in its submorphs to the clipboard"
+ | content |
+ "My own text"
+ content := self userString.
+ "Or in my submorphs"
+ content ifNil: [
+ | list |
+ list := self allStringsAfter: nil.
+ list notEmpty ifTrue: [
+ content := String streamContents: [:stream |
+ list do: [:each | stream nextPutAll: each; cr]]]].
+ "Did we find something?"
+ content
+ ifNil: [self flash "provide feedback"]
+ ifNotNil: [Clipboard clipboardText: content].!
Item was added:
+ ----- Method: Morph>>clippingBounds (in category 'drawing') -----
+ clippingBounds
+ "Return the bounds to which any submorphs should be clipped if the property is set"
+ ^self innerBounds!
Item was added:
+ ----- Method: Morph>>collapse (in category 'menus') -----
+ collapse
+ CollapsedMorph new beReplacementFor: self!
Item was added:
+ ----- Method: Morph>>color (in category 'accessing') -----
+ color
+
+ ^ color "has already been set to ((self valueOfProperty: #fillStyle) asColor)"!
Item was added:
+ ----- Method: Morph>>color: (in category 'accessing') -----
+ color: aColor
+ "Set the receiver's color. Directly set the color if appropriate, else go by way of fillStyle"
+
+ (aColor isColor or: [aColor isKindOf: InfiniteForm]) ifFalse:[^ self fillStyle: aColor].
+ color = aColor ifFalse:
+ [self removeProperty: #fillStyle.
+ color := aColor.
+ self changed]!
Item was added:
+ ----- Method: Morph>>colorChangedForSubmorph: (in category 'change reporting') -----
+ colorChangedForSubmorph: aSubmorph
+ "The color associated with aSubmorph was changed through the UI; react if needed"!
Item was added:
+ ----- Method: Morph>>colorForInsets (in category 'accessing') -----
+ colorForInsets
+ "Return the color to be used for shading inset borders. The default is my own color, but it might want to be, eg, my owner's color. Whoever's color ends up prevailing, the color itself gets the last chance to determine, so that when, for example, an InfiniteForm serves as the color, callers won't choke on some non-Color object being returned"
+ (color isColor and:[color isTransparent and:[owner notNil]]) ifTrue:[^owner colorForInsets].
+ ^ color colorForInsets
+ !
Item was added:
+ ----- Method: Morph>>colorString: (in category 'printing') -----
+ colorString: aColor
+
+ aColor ifNil: [ ^'nil' ].
+ ^aColor name
+ ifNil: [ aColor storeString ]
+ ifNotNil: [ :colorName | 'Color ', colorName ]!
Item was added:
+ ----- Method: Morph>>comeToFront (in category 'submorphs-add/remove') -----
+ comeToFront
+ | outerMorph |
+ outerMorph := self topRendererOrSelf.
+ (outerMorph owner isNil or: [outerMorph owner hasSubmorphs not])
+ ifTrue: [^self].
+ outerMorph owner firstSubmorph == outerMorph
+ ifFalse: [outerMorph owner addMorphFront: outerMorph]!
Item was added:
+ ----- Method: Morph>>comeToFrontAndAddHalo (in category 'halos and balloon help') -----
+ comeToFrontAndAddHalo
+ self comeToFront.
+ self addHalo!
Item was added:
+ ----- Method: Morph>>commandHistory (in category 'undo') -----
+ commandHistory
+ "Return the command history for the receiver"
+ | w |
+ (w := self world) ifNotNil:[^w commandHistory].
+ (w := self currentWorld) ifNotNil:[^w commandHistory].
+ ^CommandHistory new. "won't really record anything but prevent breaking things"!
Item was added:
+ ----- Method: Morph>>completeModificationHash (in category 'testing') -----
+ completeModificationHash
+
+ "World completeModificationHash"
+
+ | resultSize result |
+ resultSize := 10.
+ result := ByteArray new: resultSize.
+ self allMorphsDo: [ :each | | here |
+ here := each modificationHash.
+ here withIndexDo: [ :ch :index | | i |
+ i := index \\ resultSize + 1.
+ result at: i put: ((result at: i) bitXor: ch asciiValue)
+ ].
+ ].
+ ^result!
Item was added:
+ ----- Method: Morph>>constructorString (in category 'printing') -----
+ constructorString
+
+ ^ String streamContents: [:s | self printConstructorOn: s indent: 0].
+ !
Item was added:
+ ----- Method: Morph>>containingWindow (in category 'e-toy support') -----
+ containingWindow
+ "Answer a window or window-with-mvc that contains the receiver"
+
+ | component |
+ component := self.
+ component model isNil ifTrue: [component := self firstOwnerSuchThat: [:m| m model notNil]].
+ ^(component isNil or: [component isWindowForModel: component model])
+ ifTrue: [component]
+ ifFalse: [component firstOwnerSuchThat:[:m| m isWindowForModel: component model]]!
Item was added:
+ ----- Method: Morph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+
+ ^ self bounds containsPoint: aPoint!
Item was added:
+ ----- Method: Morph>>containsPoint:event: (in category 'events-processing') -----
+ containsPoint: aPoint event: anEvent
+ "Return true if aPoint is considered to be inside the receiver for the given event.
+ The default implementation treats locked children as integral part of their owners."
+ (self fullBounds containsPoint: aPoint) ifFalse:[^false].
+ (self containsPoint: aPoint) ifTrue:[^true].
+ self submorphsDo:[:m|
+ (m isLocked and:[m fullContainsPoint:
+ ((m transformedFrom: self) globalPointToLocal: aPoint)]) ifTrue:[^true]].
+ ^false!
Item was added:
+ ----- Method: Morph>>copy (in category 'copying') -----
+ copy
+
+ ^ self veryDeepCopy!
Item was added:
+ ----- Method: Morph>>copyToPasteBuffer: (in category 'meta-actions') -----
+ copyToPasteBuffer: evt
+ self okayToDuplicate ifTrue:[evt hand copyToPasteBuffer: self].!
Item was added:
+ ----- Method: Morph>>copyWithoutSubmorph: (in category 'submorphs-add/remove') -----
+ copyWithoutSubmorph: sub
+ "Needed to get a morph to draw without one of its submorphs.
+ NOTE: This must be thrown away immediately after use."
+ ^ self clone privateSubmorphs: (submorphs copyWithout: sub)!
Item was added:
+ ----- Method: Morph>>cornerStyle (in category 'visual properties') -----
+ cornerStyle
+ "Returns one of the following symbols:
+ #square
+ #rounded
+ according to the current corner style."
+
+ ^ self valueOfProperty: #cornerStyle ifAbsent: [#square]!
Item was added:
+ ----- Method: Morph>>cornerStyle: (in category 'rounding') -----
+ cornerStyle: aSymbol
+ "This method makes it possible to set up desired corner style. aSymbol has to be one of:
+ #square
+ #rounded"
+
+ aSymbol == #square
+ ifTrue:[self removeProperty: #cornerStyle]
+ ifFalse:[self setProperty: #cornerStyle toValue: aSymbol].
+ self changed!
Item was added:
+ ----- Method: Morph>>couldHaveRoundedCorners (in category 'accessing') -----
+ couldHaveRoundedCorners
+ ^ true!
Item was added:
+ ----- Method: Morph>>couldMakeSibling (in category 'testing') -----
+ couldMakeSibling
+ "Answer whether it is appropriate to ask the receiver to make a sibling"
+
+ ^ true!
Item was added:
+ ----- Method: Morph>>currentPlayerDo: (in category 'e-toy support') -----
+ currentPlayerDo: aBlock
+ "If the receiver is a viewer/scriptor associated with a current Player object, evaluate the given block against that object"!
Item was added:
+ ----- Method: Morph>>cursor (in category 'e-toy support') -----
+ cursor
+ "vacuous backstop in case it gets sent to a morph that doesn't know what to do with it"
+
+ ^ 1!
Item was added:
+ ----- Method: Morph>>cursor: (in category 'e-toy support') -----
+ cursor: aNumber
+ "vacuous backstop in case it gets sent to a morph that doesn't know what to do with it"
+ !
Item was added:
+ ----- Method: Morph>>cursorPoint (in category 'event handling') -----
+ cursorPoint
+ ^ self currentHand lastEvent cursorPoint!
Item was added:
+ ----- Method: Morph>>decimalPlacesForGetter: (in category 'e-toy support') -----
+ decimalPlacesForGetter: aGetter
+ "Answer the decimal places I prefer for showing a slot with the given getter, or nil if none"
+
+ | decimalPrefs |
+ decimalPrefs := self renderedMorph valueOfProperty: #decimalPlacePreferences ifAbsent: [^ nil].
+ ^ decimalPrefs at: aGetter ifAbsent: [nil]!
Item was added:
+ ----- Method: Morph>>deepCopy (in category 'copying') -----
+ deepCopy
+
+ self error: 'Please use veryDeepCopy'.
+ !
Item was added:
+ ----- Method: Morph>>defaultArrowheadSize (in category 'menus') -----
+ defaultArrowheadSize
+
+ ^ self class defaultArrowheadSize!
Item was added:
+ ----- Method: Morph>>defaultBalloonColor (in category 'halos and balloon help') -----
+ defaultBalloonColor
+ ^ Display depth <= 2
+ ifTrue: [Color white]
+ ifFalse: [BalloonMorph balloonColor]!
Item was added:
+ ----- Method: Morph>>defaultBalloonFont (in category 'halos and balloon help') -----
+ defaultBalloonFont
+ ^ BalloonMorph balloonFont!
Item was added:
+ ----- Method: Morph>>defaultBitmapFillForm (in category 'visual properties') -----
+ defaultBitmapFillForm
+ ^ImageMorph defaultForm.
+ !
Item was added:
+ ----- Method: Morph>>defaultBounds (in category 'initialization') -----
+ defaultBounds
+ "answer the default bounds for the receiver"
+ ^ 0 @ 0 corner: 50 @ 40!
Item was added:
+ ----- Method: Morph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color blue!
Item was added:
+ ----- Method: Morph>>defaultEventDispatcher (in category 'events-processing') -----
+ defaultEventDispatcher
+ "Return the default event dispatcher to use with events that are directly sent to the receiver"
+ ^MorphicEventDispatcher new!
Item was added:
+ ----- Method: Morph>>defaultLabelForInspector (in category 'user interface') -----
+ defaultLabelForInspector
+ "Answer the default label to be used for an Inspector window on the receiver."
+ ^ super printString truncateTo: 40!
Item was added:
+ ----- Method: Morph>>defaultNameStemForInstances (in category 'accessing') -----
+ defaultNameStemForInstances
+ ^self class name!
Item was added:
+ ----- Method: Morph>>defaultValueOrNil (in category 'e-toy support') -----
+ defaultValueOrNil
+ "If the receiver has a property named #defaultValue, return that property's value, else return nil"
+
+ ^ self valueOfProperty: #defaultValue ifAbsent: [nil]!
Item was added:
+ ----- Method: Morph>>defersHaloOnClickTo: (in category 'halos and balloon help') -----
+ defersHaloOnClickTo: aSubMorph
+ "If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"
+ "May want to add a way (via a property) for morphs to assert true here -- this would let certain kinds of morphs that are unusually reluctant to take the halo on initial click"
+
+ ^ false
+ !
Item was added:
+ ----- Method: Morph>>defineTempCommand (in category 'debug and other') -----
+ defineTempCommand
+ "To use this, comment out what's below here, and substitute your own code.
+ You will then be able to invoke it from the standard debugging menus. If invoked from the world menu, you'll always get it invoked on behalf of the world, but if invoked from an individual morph's meta-menu, it will be invoked on behalf of that individual morph.
+
+ Note that you can indeed reimplement tempCommand in an individual morph's class if you wish"
+
+ ToolSet browse: Morph
+ selector: #tempCommand!
Item was added:
+ ----- Method: Morph>>delete (in category 'submorphs-add/remove') -----
+ delete
+ "Remove the receiver as a submorph of its owner and make its
+ new owner be nil."
+
+ | aWorld |
+ self removeHalo.
+ aWorld := self world ifNil: [World].
+ "Terminate genie recognition focus"
+ "I encountered a case where the hand was nil, so I put in a little
+ protection - raa "
+ " This happens when we are in an MVC project and open
+ a morphic window. - BG "
+ aWorld ifNotNil:
+ [self disableSubmorphFocusForHand: self activeHand.
+ self activeHand releaseKeyboardFocus: self;
+ releaseMouseFocus: self.].
+ owner ifNotNil:[ self privateDelete.
+ self player ifNotNil: [ :player |
+ "Player must be notified"
+ player noteDeletionOf: self fromWorld: aWorld]].!
Item was added:
+ ----- Method: Morph>>deleteAnyMouseActionIndicators (in category 'debug and other') -----
+ deleteAnyMouseActionIndicators
+
+ self changed.
+ (self valueOfProperty: #mouseActionIndicatorMorphs ifAbsent: [#()]) do: [ :each |
+ each deleteWithSiblings "one is probably enough, but be safe"
+ ].
+ self removeProperty: #mouseActionIndicatorMorphs.
+ self hasRolloverBorder: false.
+ self removeProperty: #rolloverWidth.
+ self removeProperty: #rolloverColor.
+ self layoutChanged.
+ self changed.
+
+ !
Item was added:
+ ----- Method: Morph>>deleteBalloon (in category 'halos and balloon help') -----
+ deleteBalloon
+ "If I am showing a balloon, delete it."
+ | w |
+ w := self world ifNil:[^self].
+ w deleteBalloonTarget: self.!
Item was added:
+ ----- Method: Morph>>deleteDockingBars (in category 'submorphs-add/remove') -----
+ deleteDockingBars
+ "Delete the receiver's docking bars"
+ self dockingBars
+ do: [:each | each delete]!
Item was added:
+ ----- Method: Morph>>deleteSubmorphsWithProperty: (in category 'submorphs-add/remove') -----
+ deleteSubmorphsWithProperty: aSymbol
+ submorphs copy do:
+ [:m | (m hasProperty: aSymbol) ifTrue: [m delete]]!
Item was added:
+ ----- Method: Morph>>demandsBoolean (in category 'classification') -----
+ demandsBoolean
+ "Answer whether the receiver will only accept a drop if it is boolean-valued. Particular to tile-scripting."
+
+ ^ self hasProperty: #demandsBoolean!
Item was added:
+ ----- Method: Morph>>demandsThumbnailing (in category 'thumbnail') -----
+ demandsThumbnailing
+ "Answer whether the receiver, if in a thumbnailable parts bin, wants to be thumbnailed whether or not size requires it"
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>disableDragNDrop (in category 'dropping/grabbing') -----
+ disableDragNDrop
+ self enableDragNDrop: false!
Item was added:
+ ----- Method: Morph>>disableSubmorphFocusForHand: (in category 'dispatching') -----
+ disableSubmorphFocusForHand: aHandMorph
+ "Check whether this morph or any of its submorph has the Genie focus.
+ If yes, disable it."
+ !
Item was added:
+ ----- Method: Morph>>disableTableLayout (in category 'layout-properties') -----
+ disableTableLayout
+ "Layout specific. Disable laying out the receiver in table layout"
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[false] ifNotNil:[props disableTableLayout].!
Item was added:
+ ----- Method: Morph>>disableTableLayout: (in category 'layout-properties') -----
+ disableTableLayout: aBool
+ "Layout specific. Disable laying out the receiver in table layout"
+ self assureLayoutProperties disableTableLayout: aBool.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>dismissMorph (in category 'meta-actions') -----
+ dismissMorph
+ "This is called from an explicit halo destroy/delete action.
+ So first disconnect all constraints to keep the graph up to date."
+
+ (self respondsTo: #disconnectAllConstraints) "Connectors package"
+ ifTrue: [ self perform: #disconnectAllConstraints ].
+ (self respondsTo: #releaseGraphModels) "CGPrereqs package (Connectors)"
+ ifTrue: [ self perform: #releaseGraphModels ].
+ self world ifNotNilDo:
+ [:w | w abandonAllHalos; stopStepping: self].
+ self delete!
Item was added:
+ ----- Method: Morph>>dismissMorph: (in category 'meta-actions') -----
+ dismissMorph: evt
+ self dismissMorph!
Item was added:
+ ----- Method: Morph>>dismissViaHalo (in category 'submorphs-add/remove') -----
+ dismissViaHalo
+ "The user has clicked in the delete halo-handle. This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example."
+
+ | cmd |
+ self setProperty: #lastPosition toValue: self positionInWorld.
+ self dismissMorph.
+ TrashCanMorph preserveTrash ifTrue: [
+ TrashCanMorph slideDismissalsToTrash
+ ifTrue:[self slideToTrash: nil]
+ ifFalse:[TrashCanMorph moveToTrash: self].
+ ].
+
+ cmd := Command new cmdWording: 'dismiss ' translated, self externalName.
+ cmd undoTarget: ActiveWorld selector: #reintroduceIntoWorld: argument: self.
+ cmd redoTarget: ActiveWorld selector: #onceAgainDismiss: argument: self.
+ ActiveWorld rememberCommand: cmd!
Item was added:
+ ----- Method: Morph>>doButtonAction (in category 'button') -----
+ doButtonAction
+ "If the receiver has a button-action defined, do it now. The default button action of any morph is, well, to do nothing. Note that there are several ways -- too many ways -- for morphs to have button-like actions. This one refers not to the #mouseUpCodeToRun feature, nor does it refer to the Player-scripting mechanism. Instead it is intended for morph classes whose very nature is to be buttons -- this method provides glue so that arbitrary buttons on the UI can be 'fired' programatticaly from user scripts"!
Item was added:
+ ----- Method: Morph>>doCancel (in category 'user interface') -----
+ doCancel
+ self delete!
Item was added:
+ ----- Method: Morph>>doLayoutIn: (in category 'layout') -----
+ doLayoutIn: layoutBounds
+ "Compute a new layout based on the given layout bounds."
+
+ "Note: Testing for #bounds or #layoutBounds would be sufficient to
+ figure out if we need an invalidation afterwards but #outerBounds
+ is what we need for all leaf nodes so we use that."
+
+ | layout box priorBounds |
+ priorBounds := self outerBounds.
+ submorphs isEmpty ifTrue: [^fullBounds := priorBounds].
+ "Send #ownerChanged to our children"
+ submorphs do: [:m | m ownerChanged].
+ layout := self layoutPolicy.
+ layout ifNotNil: [layout layout: self in: layoutBounds].
+ self adjustLayoutBounds.
+ fullBounds := self privateFullBounds.
+ box := self outerBounds.
+ box = priorBounds
+ ifFalse: [self invalidRect: (priorBounds quickMerge: box)]!
Item was added:
+ ----- Method: Morph>>doMenuItem: (in category 'menus') -----
+ doMenuItem: menuString
+ | aMenu anItem aNominalEvent aHand |
+ aMenu := self buildHandleMenu: (aHand := self currentHand).
+ aMenu allMorphsDo: [:m | m step]. "Get wordings current"
+ anItem := aMenu itemWithWording: menuString.
+ anItem ifNil:
+ [^ self player scriptingError: 'Menu item not found: ', menuString].
+ aNominalEvent := MouseButtonEvent new
+ setType: #mouseDown
+ position: anItem bounds center
+ which: 4 "red"
+ buttons: 4 "red"
+ hand: aHand
+ stamp: nil.
+ anItem invokeWithEvent: aNominalEvent!
Item was added:
+ ----- Method: Morph>>dockingBars (in category 'submorphs-accessing') -----
+ dockingBars
+ "Answer the receiver's dockingBars"
+ ^ self submorphs
+ select: [:each | each isDockingBar]
+ !
Item was added:
+ ----- Method: Morph>>doesBevels (in category 'accessing') -----
+ doesBevels
+ "To return true means that this object can show bevelled borders, and
+ therefore can accept, eg, #raised or #inset as valid borderColors.
+ Must be overridden by subclasses that do not support bevelled borders."
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>doesOwnRotation (in category 'drawing') -----
+ doesOwnRotation
+ "Some morphs don't want to TransformMorph to rotate their images, but we do"
+ ^ false!
Item was added:
+ ----- Method: Morph>>doubleClick: (in category 'event handling') -----
+ doubleClick: evt
+ "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing.
+ LC 2/14/2000 08:32 - added: EventHandler notification"
+
+ self eventHandler ifNotNil:
+ [self eventHandler doubleClick: evt fromMorph: self].!
Item was added:
+ ----- Method: Morph>>doubleClickTimeout: (in category 'event handling') -----
+ doubleClickTimeout: evt
+ "Handle a double-click timeout event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing."
+
+ self eventHandler ifNotNil:
+ [self eventHandler doubleClickTimeout: evt fromMorph: self].!
Item was added:
+ ----- Method: Morph>>downshiftedNameOfObjectRepresented (in category 'naming') -----
+ downshiftedNameOfObjectRepresented
+ "Answer the downshiped version of the external name of the object represented"
+
+ ^ self nameOfObjectRepresented asLowercase!
Item was added:
+ ----- Method: Morph>>dragEnabled (in category 'dropping/grabbing') -----
+ dragEnabled
+ "Get this morph's ability to add and remove morphs via drag-n-drop."
+ ^(self valueOfProperty: #dragEnabled) == true
+ !
Item was added:
+ ----- Method: Morph>>dragEnabled: (in category 'dropping/grabbing') -----
+ dragEnabled: aBool
+ ^self enableDrag: aBool!
Item was added:
+ ----- Method: Morph>>dragNDropEnabled (in category 'dropping/grabbing') -----
+ dragNDropEnabled
+ "Note: This method is only useful for dragEnabled == dropEnabled at all times"
+ self separateDragAndDrop.
+ ^self dragEnabled and:[self dropEnabled]!
Item was added:
+ ----- Method: Morph>>dragSelectionColor (in category 'dropping/grabbing') -----
+ dragSelectionColor
+ ^ Color magenta!
Item was added:
+ ----- Method: Morph>>drawDropHighlightOn: (in category 'drawing') -----
+ drawDropHighlightOn: aCanvas
+
+ self highlightedForDrop ifTrue: [
+ self wantsRoundedCorners
+ ifTrue: [aCanvas frameRoundRect: self fullBounds radius: self class preferredCornerRadius width: 1 color: self dropHighlightColor]
+ ifFalse: [aCanvas frameRectangle: self fullBounds color: self dropHighlightColor]].!
Item was added:
+ ----- Method: Morph>>drawDropShadowOn: (in category 'drawing') -----
+ drawDropShadowOn: aCanvas
+ "Rectangular shadow with support for rounded corners."
+
+ | shadowBounds |
+ shadowBounds := self shadowOffset isRectangle
+ ifTrue: [self bounds outsetBy: self shadowOffset]
+ ifFalse: [self bounds translateBy: (self shadowOffset negated max: 0 at 0)].
+
+ "Only redraw the shadow if the shadow area is affected."
+ ((aCanvas clipRect intersects: shadowBounds) and: [((self bounds insetBy: (self wantsRoundedCorners ifFalse: [0] ifTrue: [self class preferredCornerRadius])) containsRect: aCanvas clipRect) not])
+ ifTrue: [
+ (self hasProperty: #dropShadow)
+ ifFalse: [self updateDropShadowCache].
+ aCanvas
+ translucentImage: (self valueOfProperty: #dropShadow)
+ at: shadowBounds topLeft].!
Item was added:
+ ----- Method: Morph>>drawErrorOn: (in category 'drawing') -----
+ drawErrorOn: aCanvas
+ "The morph (or one of its submorphs) had an error in its drawing method."
+ | saneBounds |
+ saneBounds := bounds rounded.
+ aCanvas
+ frameAndFillRectangle: saneBounds
+ fillColor: Color red
+ borderWidth: 1
+ borderColor: Color yellow.
+ aCanvas line: saneBounds topLeft to: saneBounds bottomRight width: 1 color: Color yellow.
+ aCanvas line: saneBounds topRight to: saneBounds bottomLeft width: 1 color: Color yellow.!
Item was added:
+ ----- Method: Morph>>drawKeyboardFocusIndicationOn: (in category 'drawing') -----
+ drawKeyboardFocusIndicationOn: aCanvas
+
+ self wantsRoundedCorners
+ ifTrue: [aCanvas frameRoundRect: self bounds radius: self class preferredCornerRadius width: 3 "self borderStyle width" color: self keyboardFocusColor]
+ ifFalse: [aCanvas frameRectangle: self bounds width: 3 "self borderStyle width" color: self keyboardFocusColor].!
Item was added:
+ ----- Method: Morph>>drawMouseDownHighlightOn: (in category 'drawing') -----
+ drawMouseDownHighlightOn: aCanvas
+
+ self highlightedForMouseDown ifTrue: [
+ self wantsRoundedCorners
+ ifTrue: [aCanvas frameRoundRect: self fullBounds radius: self class preferredCornerRadius width: 1 color: self color darker darker]
+ ifFalse: [aCanvas frameRectangle: self fullBounds color: self color darker darker]].!
Item was added:
+ ----- Method: Morph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ self wantsRoundedCorners
+ ifTrue: [aCanvas frameAndFillRoundRect: self bounds radius: self class preferredCornerRadius fillStyle: self fillStyle borderWidth: self borderStyle width borderColor: self borderStyle color]
+ ifFalse: [aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle].
+
+ !
Item was added:
+ ----- Method: Morph>>drawOnCanvas: (in category 'filter streaming') -----
+ drawOnCanvas: aCanvas
+ ^aCanvas fullDraw: self.
+ !
Item was added:
+ ----- Method: Morph>>drawOverlayOn: (in category 'drawing') -----
+ drawOverlayOn: aCanvas
+ "Draw something over all my submorphs."
+
+ self drawDropHighlightOn: aCanvas.
+ self drawMouseDownHighlightOn: aCanvas.
+
+ (self indicateKeyboardFocus and: [self hasKeyboardFocus])
+ ifTrue: [self drawKeyboardFocusIndicationOn: aCanvas].!
Item was added:
+ ----- Method: Morph>>drawPostscriptOn: (in category '*morphic-Postscript Canvases') -----
+ drawPostscriptOn: aCanvas
+
+ self drawOn:aCanvas.
+ !
Item was added:
+ ----- Method: Morph>>drawRolloverBorderOn: (in category 'drawing') -----
+ drawRolloverBorderOn: aCanvas
+ | colorToUse offsetToUse myShadow newForm f |
+ colorToUse := self
+ valueOfProperty: #rolloverColor
+ ifAbsent: [Color blue alpha: 0.5].
+ offsetToUse := self
+ valueOfProperty: #rolloverWidth
+ ifAbsent: [10 @ 10].
+ self hasRolloverBorder: false.
+ myShadow := self shadowForm.
+ self hasRolloverBorder: true.
+ myShadow offset: 0 @ 0.
+ f := ColorForm extent: myShadow extent depth: 1.
+ myShadow displayOn: f.
+ f colors: {Color transparent. colorToUse}.
+ newForm := Form extent: offsetToUse * 2 + myShadow extent depth: 32.
+ (WarpBlt toForm: newForm) sourceForm: f;
+ cellSize: 1;
+ combinationRule: 3;
+ copyQuad: f boundingBox innerCorners toRect: newForm boundingBox.
+
+ self flag: #roundedCorners. "mt: Check for #wantsRoundedCorners and call appropriate things in canvas."
+ aCanvas
+ translateBy: offsetToUse negated
+ during: [:shadowCanvas |
+ shadowCanvas shadowColor: colorToUse.
+ shadowCanvas paintImage: newForm at: self position]!
Item was added:
+ ----- Method: Morph>>drawSubmorphsOn: (in category 'drawing') -----
+ drawSubmorphsOn: aCanvas
+ "Display submorphs back to front"
+
+ | drawBlock |
+ submorphs isEmpty ifTrue: [^self].
+ drawBlock := [:canvas | submorphs reverseDo: [:m | canvas fullDrawMorph: m]].
+ self clipSubmorphs
+ ifTrue: [aCanvas clipBy: self clippingBounds during: drawBlock]
+ ifFalse: [drawBlock value: aCanvas]!
Item was added:
+ ----- Method: Morph>>dropEnabled (in category 'dropping/grabbing') -----
+ dropEnabled
+ "Get this morph's ability to add and remove morphs via drag-n-drop."
+ ^(self valueOfProperty: #dropEnabled) == true
+ !
Item was added:
+ ----- Method: Morph>>dropEnabled: (in category 'dropping/grabbing') -----
+ dropEnabled: aBool
+ ^self enableDrop: aBool!
Item was added:
+ ----- Method: Morph>>dropFiles: (in category 'event handling') -----
+ dropFiles: anEvent
+ "Handle a number of files dropped from the OS"
+ !
Item was added:
+ ----- Method: Morph>>dropHighlightColor (in category 'dropping/grabbing') -----
+ dropHighlightColor
+ ^ Color blue!
Item was added:
+ ----- Method: Morph>>dropSuccessColor (in category 'dropping/grabbing') -----
+ dropSuccessColor
+ ^ Color blue!
Item was added:
+ ----- Method: Morph>>duplicate (in category 'copying') -----
+ duplicate
+ "Make and return a duplicate of the receiver"
+
+ | newMorph aName w aPlayer topRend |
+ ((topRend := self topRendererOrSelf) ~~ self) ifTrue: [^ topRend duplicate].
+
+ self okayToDuplicate ifFalse: [^ self].
+ aName := (w := self world) ifNotNil:
+ [w nameForCopyIfAlreadyNamed: self].
+ newMorph := self veryDeepCopy.
+ aName ifNotNil: [newMorph setNameTo: aName].
+
+ newMorph arrangeToStartStepping.
+ newMorph privateOwner: nil. "no longer in world"
+ newMorph isPartsDonor: false. "no longer parts donor"
+ (aPlayer := newMorph player) belongsToUniClass ifTrue:
+ [aPlayer class bringScriptsUpToDate].
+ aPlayer ifNotNil: [ActiveWorld presenter flushPlayerListCache].
+ ^ newMorph!
Item was added:
+ ----- Method: Morph>>duplicateMorph: (in category 'meta-actions') -----
+ duplicateMorph: evt
+ "Make and return a duplicate of the receiver's argument"
+ | dup |
+ dup := self duplicate.
+ evt hand grabMorph: dup from: owner. "duplicate was ownerless so use #grabMorph:from: here"
+ ^dup!
Item was added:
+ ----- Method: Morph>>duplicateMorphCollection: (in category 'copying') -----
+ duplicateMorphCollection: aCollection
+ "Make and return a duplicate of the receiver"
+
+ | newCollection names |
+
+ names := aCollection collect: [ :ea | | newMorph w |
+ (w := ea world) ifNotNil:
+ [w nameForCopyIfAlreadyNamed: ea].
+ ].
+
+ newCollection := aCollection veryDeepCopy.
+
+ newCollection with: names do: [ :newMorph :name |
+ name ifNotNil: [ newMorph setNameTo: name ].
+ newMorph arrangeToStartStepping.
+ newMorph privateOwner: nil. "no longer in world"
+ newMorph isPartsDonor: false. "no longer parts donor"
+ ].
+
+ ^newCollection!
Item was added:
+ ----- Method: Morph>>duplicateMorphImage: (in category 'meta-actions') -----
+ duplicateMorphImage: evt
+ "Make and return a imageMorph of the receiver's argument imageForm"
+ | dup |
+ dup := self asSnapshotThumbnail withSnapshotBorder.
+ dup bounds: self bounds.
+ evt hand grabMorph: dup from: owner.
+ "duplicate was ownerless so use #grabMorph:from: here"
+ ^ dup!
Item was added:
+ ----- Method: Morph>>eToyRejectDropMorph:event: (in category 'WiW support') -----
+ eToyRejectDropMorph: morphToDrop event: evt
+
+ | tm am |
+
+ tm := TextMorph new
+ beAllFont: ((TextStyle named: Preferences standardEToysFont familyName) fontOfSize: 24);
+ contents: 'GOT IT!!'.
+ (am := AlignmentMorph new)
+ color: Color yellow;
+ layoutInset: 10;
+ useRoundedCorners;
+ vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
+ addMorph: tm;
+ fullBounds;
+ position: (self bounds center - (am extent // 2));
+ openInWorld: self world.
+ SoundService default playSoundNamed: 'yum' ifAbsentReadFrom: 'yum.aif'.
+ morphToDrop rejectDropMorphEvent: evt. "send it back where it came from"
+ am delete
+ !
Item was added:
+ ----- Method: Morph>>editBalloonHelpContent: (in category 'halos and balloon help') -----
+ editBalloonHelpContent: aString
+ | reply |
+ reply := UIManager default
+ multiLineRequest: 'Edit the balloon help text for ' translated, self externalName
+ centerAt: Sensor cursorPoint
+ initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString])
+ answerHeight: 200.
+ reply ifNil: [^ self]. "User cancelled out of the dialog"
+ (reply isEmpty or: [reply asString = self noHelpString])
+ ifTrue: [self setBalloonText: nil]
+ ifFalse: [self setBalloonText: reply]!
Item was added:
+ ----- Method: Morph>>editBalloonHelpText (in category 'halos and balloon help') -----
+ editBalloonHelpText
+ "Modify the receiver's balloon help text."
+
+ self editBalloonHelpContent: self balloonText!
Item was added:
+ ----- Method: Morph>>embedInWindow (in category 'e-toy support') -----
+ embedInWindow
+
+ | window worldToUse |
+
+ worldToUse := self world. "I'm assuming we are already in a world"
+ window := (SystemWindow labelled: self defaultLabelForInspector) model: nil.
+ window bounds: ((self position - ((0 at window labelHeight) + window borderWidth))
+ corner: self bottomRight + window borderWidth).
+ window addMorph: self frame: (0 at 0 extent: 1 at 1).
+ window updatePaneColors.
+ worldToUse addMorph: window.
+ window activate!
Item was added:
+ ----- Method: Morph>>embedInto: (in category 'meta-actions') -----
+ embedInto: evt
+ "Embed the receiver into some other morph"
+ | target morphs |
+ morphs := self potentialEmbeddingTargets.
+ target := UIManager default
+ chooseFrom: (morphs collect:[:m| m knownName ifNil:[m class name asString]])
+ values: self potentialEmbeddingTargets
+ title: ('Place ', self externalName, ' in...').
+ target ifNil:[^self].
+ target addMorphFrontFromWorldPosition: self!
Item was added:
+ ----- Method: Morph>>embeddedInMorphicWindowLabeled: (in category 'e-toy support') -----
+ embeddedInMorphicWindowLabeled: labelString
+ | window |
+ window := (SystemWindow labelled: labelString) model: nil.
+ window setStripeColorsFrom: nil defaultBackgroundColor.
+ window addMorph: self frame: (0 at 0 extent: 1 at 1).
+ ^ window!
Item was added:
+ ----- Method: Morph>>enableDrag: (in category 'dropping/grabbing') -----
+ enableDrag: aBoolean
+ self setProperty: #dragEnabled toValue: aBoolean!
Item was added:
+ ----- Method: Morph>>enableDragNDrop (in category 'dropping/grabbing') -----
+ enableDragNDrop
+ self enableDragNDrop: true!
Item was added:
+ ----- Method: Morph>>enableDragNDrop: (in category 'dropping/grabbing') -----
+ enableDragNDrop: aBoolean
+ "Set both properties at once"
+ self separateDragAndDrop.
+ self enableDrag: aBoolean.
+ self enableDrop: aBoolean.!
Item was added:
+ ----- Method: Morph>>enableDrop: (in category 'dropping/grabbing') -----
+ enableDrop: aBoolean
+ self setProperty: #dropEnabled toValue: aBoolean!
Item was added:
+ ----- Method: Morph>>encounteredAtTime:inScorePlayer:atIndex:inEventTrack:secsPerTick: (in category '*Morphic-Sound-piano rolls') -----
+ encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick
+
+ "a hack to allow for abitrary morphs to be dropped into piano roll"
+ self triggerActionFromPianoRoll.!
Item was added:
+ ----- Method: Morph>>eventHandler (in category 'accessing') -----
+ eventHandler
+ "answer the receiver's eventHandler"
+ ^ extension ifNotNil: [extension eventHandler] !
Item was added:
+ ----- Method: Morph>>eventHandler: (in category 'accessing') -----
+ eventHandler: anEventHandler
+ "Note that morphs can share eventHandlers and all is OK. "
+ self assureExtension eventHandler: anEventHandler!
Item was added:
+ ----- Method: Morph>>expandFullBoundsForDropShadow: (in category 'drawing') -----
+ expandFullBoundsForDropShadow: aRectangle
+ "Return an expanded rectangle for an eventual drop shadow"
+ | delta box |
+
+ self shadowOffset isRectangle
+ ifTrue: [^ aRectangle outsetBy: self shadowOffset].
+
+ box := aRectangle.
+ delta := self shadowOffset.
+ box := delta x >= 0
+ ifTrue:[box right: aRectangle right + delta x]
+ ifFalse:[box left: aRectangle left + delta x].
+ box := delta y >= 0
+ ifTrue:[box bottom: aRectangle bottom + delta y]
+ ifFalse:[box top: aRectangle top + delta y].
+ ^box!
Item was added:
+ ----- Method: Morph>>expandFullBoundsForRolloverBorder: (in category 'drawing') -----
+ expandFullBoundsForRolloverBorder: aRectangle
+ | delta |
+ delta := self valueOfProperty: #rolloverWidth ifAbsent: [10 at 10].
+ ^aRectangle expandBy: delta.
+
+ !
Item was added:
+ ----- Method: Morph>>exploreInMorphic (in category 'menus') -----
+ exploreInMorphic
+
+ ToolSet explore: self.!
Item was added:
+ ----- Method: Morph>>exploreInMorphic: (in category 'menus') -----
+ exploreInMorphic: evt
+
+ ToolSet explore: self.!
Item was added:
+ ----- Method: Morph>>exportAsBMP (in category 'menus') -----
+ exportAsBMP
+ | fName |
+ fName := UIManager default request:'Please enter the name' translated initialAnswer: self externalName,'.bmp'.
+ fName isEmpty ifTrue:[^self].
+ self exportAsBMPNamed: fName!
Item was added:
+ ----- Method: Morph>>exportAsBMPNamed: (in category 'menus') -----
+ exportAsBMPNamed: aString
+ self imageForm writeBMPfileNamed: aString!
Item was added:
+ ----- Method: Morph>>exportAsGIF (in category 'menus') -----
+ exportAsGIF
+ | fName |
+ fName := UIManager default request:'Please enter the name' translated initialAnswer: self externalName,'.gif'.
+ fName isEmpty ifTrue:[^self].
+ self exportAsGIFNamed: fName!
Item was added:
+ ----- Method: Morph>>exportAsGIFNamed: (in category 'menus') -----
+ exportAsGIFNamed: aString
+ GIFReadWriter
+ putForm: self imageForm
+ onFileNamed: aString!
Item was added:
+ ----- Method: Morph>>exportAsJPEG (in category 'menus') -----
+ exportAsJPEG
+ | fName |
+ fName := UIManager default request: 'Please enter the name' translated initialAnswer: self externalName,'.jpeg'.
+ fName isEmpty ifTrue: [^ self].
+ self exportAsJPEGNamed: fName!
Item was added:
+ ----- Method: Morph>>exportAsJPEGNamed: (in category 'menus') -----
+ exportAsJPEGNamed: aString
+ self imageForm writeJPEGfileNamed: aString!
Item was added:
+ ----- Method: Morph>>exportAsPNG (in category 'menus') -----
+ exportAsPNG
+ | fName |
+ fName := UIManager default request:'Please enter the name' translated initialAnswer: self externalName,'.png'.
+ fName isEmpty ifTrue:[^self].
+ self exportAsPNGNamed: fName!
Item was added:
+ ----- Method: Morph>>exportAsPNGNamed: (in category 'menus') -----
+ exportAsPNGNamed: aString
+ PNGReadWriter
+ putForm: self imageForm
+ onFileNamed: aString!
Item was added:
+ ----- Method: Morph>>extension (in category 'accessing - extension') -----
+ extension
+ "answer the recevier's extension"
+ ^ extension!
Item was added:
+ ----- Method: Morph>>extent (in category 'geometry') -----
+ extent
+
+ ^ bounds extent!
Item was added:
+ ----- Method: Morph>>extent: (in category 'geometry') -----
+ extent: aPoint
+
+ (bounds extent closeTo: aPoint) ifTrue: [^ self].
+ self changed.
+ bounds := (bounds topLeft extent: aPoint) rounded.
+ self removeProperty: #dropShadow.
+ self layoutChanged.
+ self changed.
+ !
Item was added:
+ ----- Method: Morph>>externalName (in category 'viewer') -----
+ externalName
+ ^ self knownName ifNil: [self innocuousName]!
Item was added:
+ ----- Method: Morph>>fillStyle (in category 'visual properties') -----
+ fillStyle
+ "Return the current fillStyle of the receiver."
+ ^ self
+ valueOfProperty: #fillStyle
+ ifAbsent: ["Workaround already converted morphs"
+ color
+ ifNil: [self defaultColor]]!
Item was added:
+ ----- Method: Morph>>fillStyle: (in category 'visual properties') -----
+ fillStyle: aFillStyle
+ "Set the current fillStyle of the receiver."
+ self setProperty: #fillStyle toValue: aFillStyle.
+ "Workaround for Morphs not yet converted"
+ color := aFillStyle asColor.
+ self changed.!
Item was added:
+ ----- Method: Morph>>fillWithRamp:oriented: (in category 'visual properties') -----
+ fillWithRamp: rampSpecsOrColor oriented: aRatio
+ rampSpecsOrColor isColor
+ ifTrue: [self color: rampSpecsOrColor".
+ self borderColor: rampSpecsOrColor muchDarker"]
+ ifFalse: [| fill |
+ fill := GradientFillStyle ramp: rampSpecsOrColor.
+ fill origin: self bounds topLeft.
+ fill direction: (self bounds extent * aRatio) truncated.
+ fill radial: false.
+ self fillStyle: fill.
+ self borderColor: (rampSpecsOrColor first value mixed: 0.5 with: rampSpecsOrColor last value) muchDarker]!
Item was added:
+ ----- Method: Morph>>findA: (in category 'submorphs-accessing') -----
+ findA: aClass
+ "Return the first submorph of the receiver that is descended from the given class. Return nil if there is no such submorph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."
+
+ ^self submorphs
+ detect: [:p | p isKindOf: aClass]
+ ifNone: [nil]!
Item was added:
+ ----- Method: Morph>>findDeepSubmorphThat:ifAbsent: (in category 'submorphs-accessing') -----
+ findDeepSubmorphThat: block1 ifAbsent: block2
+ self
+ allMorphsDo: [:m | (block1 value: m)
+ == true ifTrue: [^ m]].
+ ^ block2 value!
Item was added:
+ ----- Method: Morph>>findDeeplyA: (in category 'submorphs-accessing') -----
+ findDeeplyA: aClass
+ "Return a morph in the submorph tree of the receiver that is descended from the given class. Return nil if there is no such morph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."
+
+ ^ (self allMorphs copyWithout: self)
+ detect: [:p | p isKindOf: aClass]
+ ifNone: [nil]!
Item was added:
+ ----- Method: Morph>>findSubmorphBinary: (in category 'submorphs-accessing') -----
+ findSubmorphBinary: aBlock
+ "Use binary search for finding a specific submorph of the receiver. Caller must be certain that the ordering holds for the submorphs."
+ ^submorphs findBinary: aBlock ifNone:[nil].!
Item was added:
+ ----- Method: Morph>>firstClickTimedOut: (in category 'event handling') -----
+ firstClickTimedOut: evt
+ "Useful for double-click candidates who want to know whether or not the click is a single or double. In this case, ignore the #click: and wait for either this or #doubleClick:"
+
+ !
Item was added:
+ ----- Method: Morph>>firstOwnerSuchThat: (in category 'structure') -----
+ firstOwnerSuchThat: conditionBlock
+
+ self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]].
+ ^ nil
+ !
Item was added:
+ ----- Method: Morph>>firstSubmorph (in category 'submorphs-accessing') -----
+ firstSubmorph
+ ^submorphs first!
Item was added:
+ ----- Method: Morph>>flash (in category 'macpal') -----
+ flash
+ | originalColor |
+ originalColor := self color.
+ [ self color:
+ (originalColor
+ ifNil: [ Color black ]
+ ifNotNil: [( (originalColor alpha: 1) adjustSaturation: 0.8 brightness: 0) negated ]) ]
+ ensure:
+ [ self world ifNotNil: [ : w | w displayWorldSafely ].
+ self color: originalColor ]!
Item was added:
+ ----- Method: Morph>>flashBounds (in category 'drawing') -----
+ flashBounds
+ "Flash the receiver's bounds -- does not use the receiver's color, thus works with StringMorphs and SketchMorphs, etc., for which #flash is useless. No senders initially, but useful to send this from a debugger or inspector"
+
+ 5 timesRepeat:
+ [Display flash: self boundsInWorld andWait: 120]!
Item was added:
+ ----- Method: Morph>>formerOwner (in category 'dropping/grabbing') -----
+ formerOwner
+ ^self valueOfProperty: #formerOwner!
Item was added:
+ ----- Method: Morph>>formerOwner: (in category 'dropping/grabbing') -----
+ formerOwner: aMorphOrNil
+ aMorphOrNil
+ ifNil: [self removeProperty: #formerOwner]
+ ifNotNil: [self setProperty: #formerOwner toValue: aMorphOrNil]!
Item was added:
+ ----- Method: Morph>>formerPosition (in category 'dropping/grabbing') -----
+ formerPosition
+ ^self valueOfProperty: #formerPosition!
Item was added:
+ ----- Method: Morph>>formerPosition: (in category 'dropping/grabbing') -----
+ formerPosition: formerPosition
+ formerPosition
+ ifNil: [self removeProperty: #formerPosition]
+ ifNotNil: [self setProperty: #formerPosition toValue: formerPosition]!
Item was added:
+ ----- Method: Morph>>forwardDirection (in category 'accessing') -----
+ forwardDirection
+ "Return the receiver's forward direction (in eToy terms)"
+ ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]!
Item was added:
+ ----- Method: Morph>>fullBounds (in category 'layout') -----
+ fullBounds
+ "Return the bounding box of the receiver and all its children. Recompute the layout if necessary."
+ fullBounds ifNotNil:[^fullBounds].
+ "Errors at this point can be critical so make sure we catch 'em all right"
+ [self doLayoutIn: self layoutBounds] on: Error do:[:ex|
+ "This should do it unless you don't screw up the bounds"
+ fullBounds := bounds.
+ ex pass].
+ ^fullBounds!
Item was added:
+ ----- Method: Morph>>fullBoundsInWorld (in category 'geometry') -----
+ fullBoundsInWorld
+ ^self bounds: self fullBounds in: self world!
Item was added:
+ ----- Method: Morph>>fullContainsPoint: (in category 'geometry testing') -----
+ fullContainsPoint: aPoint
+
+ (self fullBounds containsPoint: aPoint) ifFalse: [^ false]. "quick elimination"
+ (self containsPoint: aPoint) ifTrue: [^ true]. "quick acceptance"
+ submorphs do: [:m | (m fullContainsPoint: aPoint) ifTrue: [^ true]].
+ ^ false
+ !
Item was added:
+ ----- Method: Morph>>fullCopy (in category 'copying') -----
+ fullCopy
+ "Deprecated, but maintained for backward compatibility with existing code (no senders in the base 3.0 image). Calls are revectored to #veryDeepCopy, but note that #veryDeepCopy does not do exactly the same thing that the original #fullCopy did, so beware!!"
+
+ ^ self veryDeepCopy!
Item was added:
+ ----- Method: Morph>>fullDrawOn: (in category 'drawing') -----
+ fullDrawOn: aCanvas
+ "Draw the full Morphic structure on the given Canvas"
+
+ self visible ifFalse: [^ self].
+ (aCanvas isVisible: self fullBounds) ifFalse:[^self].
+ (self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas].
+ "Note: At some point we should generalize this into some sort of
+ multi-canvas so that we can cross-optimize some drawing operations."
+
+ "Pass 1: Draw eventual drop-shadow"
+ self hasDropShadow ifTrue: [self drawDropShadowOn: aCanvas].
+ (self hasRolloverBorder and: [(aCanvas seesNothingOutside: self bounds) not])
+ ifTrue: [self drawRolloverBorderOn: aCanvas].
+
+ "Pass 2: Draw receiver itself"
+ (aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self].
+ self drawSubmorphsOn: aCanvas.
+ self drawOverlayOn: aCanvas.!
Item was added:
+ ----- Method: Morph>>fullDrawPostscriptOn: (in category '*morphic-Postscript Canvases') -----
+ fullDrawPostscriptOn: aCanvas
+
+ self fullDrawOn:aCanvas.
+ !
Item was added:
+ ----- Method: Morph>>fullLoadCachedState (in category 'caching') -----
+ fullLoadCachedState
+ "Load the cached state of the receiver and its full submorph tree."
+
+ self allMorphsDo: [:m | m loadCachedState].
+ !
Item was added:
+ ----- Method: Morph>>fullPrintOn: (in category 'printing') -----
+ fullPrintOn: aStream
+
+ aStream nextPutAll: self class name , ' newBounds: (';
+ print: bounds;
+ nextPutAll: ') color: ' , (self colorString: color)!
Item was added:
+ ----- Method: Morph>>fullReleaseCachedState (in category 'caching') -----
+ fullReleaseCachedState
+ "Release the cached state of the receiver and its full submorph tree."
+
+ self allMorphsDo: [:m | m releaseCachedState].
+ !
Item was added:
+ ----- Method: Morph>>getNumericValue (in category 'e-toy support') -----
+ getNumericValue
+ "Only certain kinds of morphs know how to deal with this frontally; here we provide support for a numeric property of any morph"
+
+ ^ self valueOfProperty: #numericValue ifAbsent: [0]!
Item was added:
+ ----- Method: Morph>>globalPointToLocal: (in category 'geometry') -----
+ globalPointToLocal: aPoint
+ ^self point: aPoint from: nil!
Item was added:
+ ----- Method: Morph>>goBehind (in category 'submorphs-add/remove') -----
+ goBehind
+
+ owner addMorphNearBack: self.
+ !
Item was added:
+ ----- Method: Morph>>grabMorph: (in category 'meta-actions') -----
+ grabMorph: evt
+
+ evt hand grabMorph: self!
Item was added:
+ ----- Method: Morph>>grabTransform (in category 'dropping/grabbing') -----
+ grabTransform
+ "Return the transform for the receiver which should be applied during grabbing"
+ ^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]!
Item was added:
+ ----- Method: Morph>>gridFormOrigin:grid:background:line: (in category 'e-toy support') -----
+ gridFormOrigin: origin grid: smallGrid background: backColor line: lineColor
+
+ | bigGrid gridForm gridOrigin |
+ gridOrigin := origin \\ smallGrid.
+ bigGrid := (smallGrid asPoint x) @ (smallGrid asPoint y).
+ gridForm := Form extent: bigGrid depth: Display depth.
+ backColor ifNotNil: [gridForm fillWithColor: backColor].
+ gridOrigin x to: gridForm width by: smallGrid x do:
+ [:x | gridForm fill: (x at 0 extent: 1 at gridForm height) fillColor: lineColor].
+ gridOrigin y to: gridForm height by: smallGrid y do:
+ [:y | gridForm fill: (0 at y extent: gridForm width at 1) fillColor: lineColor].
+ ^ InfiniteForm with: gridForm
+ !
Item was added:
+ ----- Method: Morph>>gridPoint: (in category 'geometry') -----
+ gridPoint: ungriddedPoint
+
+ ^ ungriddedPoint!
Item was added:
+ ----- Method: Morph>>griddedPoint: (in category 'geometry') -----
+ griddedPoint: ungriddedPoint
+
+ | griddingContext |
+ self flag: #arNote. "Used by event handling - should transform to pasteUp for gridding"
+ (griddingContext := self pasteUpMorph) ifNil: [^ ungriddedPoint].
+ ^ griddingContext gridPoint: ungriddedPoint!
Item was added:
+ ----- Method: Morph>>hResizing (in category 'layout-properties') -----
+ hResizing
+ "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
+ #rigid - do not resize the receiver
+ #spaceFill - resize to fill owner's available space
+ #shrinkWrap - resize to fit children
+ "
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#rigid] ifNotNil:[props hResizing].!
Item was added:
+ ----- Method: Morph>>hResizing: (in category 'layout-properties') -----
+ hResizing: aSymbol
+ "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
+ #rigid - do not resize the receiver
+ #spaceFill - resize to fill owner's available space
+ #shrinkWrap - resize to fit children
+ "
+ self assureLayoutProperties hResizing: aSymbol.
+ self layoutChanged.
+ !
Item was added:
+ ----- Method: Morph>>hResizingString: (in category 'layout-properties') -----
+ hResizingString: aSymbol
+ ^self layoutMenuPropertyString: aSymbol from: self hResizing!
Item was added:
+ ----- Method: Morph>>halo (in category 'halos and balloon help') -----
+ halo
+
+ (self outermostWorldMorph ifNil: [^nil]) haloMorphs do: [:h | h target == self ifTrue: [^ h]].
+ ^ nil!
Item was added:
+ ----- Method: Morph>>haloClass (in category 'halos and balloon help') -----
+ haloClass
+ "Answer the name of the desired kind of HaloMorph to launch on behalf of the receiver"
+
+ ^ #HaloMorph
+ !
Item was added:
+ ----- Method: Morph>>haloDelayTime (in category 'halos and balloon help') -----
+ haloDelayTime
+ "Return the number of milliseconds before a halo should be put up on the receiver. The halo will only be put up if the receiver responds to #wantsHalo by returning true."
+ ^800!
Item was added:
+ ----- Method: Morph>>handUserASibling (in category 'e-toy support') -----
+ handUserASibling
+ "Make and hand the user a sibling instance. Force the creation of a uniclass at this point if one does not already exist for the receiver."
+
+ | topRend |
+ topRend := self topRendererOrSelf.
+ topRend couldMakeSibling ifFalse: [^ Beeper beep].
+
+ topRend assuredPlayer assureUniClass.
+ (topRend makeSiblings: 1) first openInHand!
Item was added:
+ ----- Method: Morph>>handleDropFiles: (in category 'events-processing') -----
+ handleDropFiles: anEvent
+ "Handle a drop from the OS."
+ anEvent wasHandled ifTrue:[^self]. "not interested"
+ (self wantsDropFiles: anEvent) ifFalse:[^self].
+ anEvent wasHandled: true.
+ self dropFiles: anEvent.
+ !
Item was added:
+ ----- Method: Morph>>handleDropMorph: (in category 'events-processing') -----
+ handleDropMorph: anEvent
+ "Handle a dropping morph."
+ | aMorph localPt |
+ aMorph := anEvent contents.
+ "Do a symmetric check if both morphs like each other"
+ ((self wantsDroppedMorph: aMorph event: anEvent) "I want her"
+ and: [aMorph wantsToBeDroppedInto: self]) "she wants me"
+ ifFalse: [aMorph removeProperty: #undoGrabCommand.
+ ^ self].
+ anEvent wasHandled: true.
+ "Transform the morph into the receiver's coordinate frame. This is currently incomplete since it only takes the offset into account where it really should take the entire transform."
+ localPt := (self transformedFrom: anEvent hand world) "full transform down"
+ globalPointToLocal: aMorph referencePosition.
+ aMorph referencePosition: localPt.
+ self acceptDroppingMorph: aMorph event: anEvent.
+ aMorph justDroppedInto: self event: anEvent.
+ !
Item was added:
+ ----- Method: Morph>>handleEvent: (in category 'events-processing') -----
+ handleEvent: anEvent
+ "Handle the given event"
+ ^anEvent sentTo: self.!
Item was added:
+ ----- Method: Morph>>handleFocusEvent: (in category 'events-processing') -----
+ handleFocusEvent: anEvent
+ "Handle the given event. This message is sent if the receiver currently has the focus and is therefore receiving events directly from some hand."
+ ^self handleEvent: anEvent!
Item was added:
+ ----- Method: Morph>>handleKeyDown: (in category 'events-processing') -----
+ handleKeyDown: anEvent
+ "System level event handling."
+ anEvent wasHandled ifTrue:[^self].
+ (self handlesKeyboard: anEvent) ifFalse:[^self].
+ anEvent wasHandled: true.
+ ^self keyDown: anEvent!
Item was added:
+ ----- Method: Morph>>handleKeyUp: (in category 'events-processing') -----
+ handleKeyUp: anEvent
+ "System level event handling."
+ anEvent wasHandled ifTrue:[^self].
+ (self handlesKeyboard: anEvent) ifFalse:[^self].
+ anEvent wasHandled: true.
+ ^self keyUp: anEvent!
Item was added:
+ ----- Method: Morph>>handleKeystroke: (in category 'events-processing') -----
+ handleKeystroke: anEvent
+ "System level event handling."
+
+ anEvent wasHandled
+ ifTrue: [^ self].
+ (self handlesKeyboard: anEvent)
+ ifFalse: [^ self].
+ anEvent wasHandled: true.
+ ^ self keyStroke: anEvent!
Item was added:
+ ----- Method: Morph>>handleListenEvent: (in category 'events-processing') -----
+ handleListenEvent: anEvent
+ "Handle the given event. This message is sent if the receiver is a registered listener for the given event."
+ ^anEvent sentTo: self.!
Item was added:
+ ----- Method: Morph>>handleMouseDown: (in category 'events-processing') -----
+ handleMouseDown: anEvent
+ "System level event handling."
+ anEvent wasHandled ifTrue:[^self]. "not interested"
+ anEvent hand removePendingBalloonFor: self.
+ anEvent hand removePendingHaloFor: self.
+ anEvent wasHandled: true.
+
+ (anEvent controlKeyPressed
+ and: [anEvent blueButtonChanged not
+ and: [Preferences cmdGesturesEnabled]])
+ ifTrue: [^ self invokeMetaMenu: anEvent].
+
+ "Make me modal during mouse transitions"
+ anEvent hand newMouseFocus: self event: anEvent.
+ anEvent blueButtonChanged ifTrue:[^self blueButtonDown: anEvent].
+
+ "this mouse down could be the start of a gesture, or the end of a gesture focus"
+ (self isGestureStart: anEvent)
+ ifTrue: [^ self gestureStart: anEvent].
+
+ self mouseDown: anEvent.
+
+ Preferences maintainHalos
+ ifFalse:[ anEvent hand removeHaloFromClick: anEvent on: self ].
+
+ (self handlesMouseStillDown: anEvent) ifTrue:[
+ self startStepping: #handleMouseStillDown:
+ at: Time millisecondClockValue + self mouseStillDownThreshold
+ arguments: {anEvent copy resetHandlerFields}
+ stepTime: self mouseStillDownStepRate ].
+ !
Item was added:
+ ----- Method: Morph>>handleMouseEnter: (in category 'events-processing') -----
+ handleMouseEnter: anEvent
+ "System level event handling."
+ (anEvent isDraggingEvent) ifTrue:[
+ (self handlesMouseOverDragging: anEvent) ifTrue:[
+ anEvent wasHandled: true.
+ self mouseEnterDragging: anEvent].
+ ^self].
+ self wantsHalo "If receiver wants halo and balloon, trigger balloon after halo"
+ ifTrue:[anEvent hand triggerHaloFor: self after: self haloDelayTime]
+ ifFalse:[self wantsBalloon
+ ifTrue:[anEvent hand triggerBalloonFor: self after: self balloonHelpDelayTime]].
+ (self handlesMouseOver: anEvent) ifTrue:[
+ anEvent wasHandled: true.
+ self mouseEnter: anEvent.
+ ].!
Item was added:
+ ----- Method: Morph>>handleMouseLeave: (in category 'events-processing') -----
+ handleMouseLeave: anEvent
+ "System level event handling."
+ anEvent hand removePendingBalloonFor: self.
+ anEvent hand removePendingHaloFor: self.
+ anEvent isDraggingEvent ifTrue:[
+ (self handlesMouseOverDragging: anEvent) ifTrue:[
+ anEvent wasHandled: true.
+ self mouseLeaveDragging: anEvent].
+ ^self].
+ (self handlesMouseOver: anEvent) ifTrue:[
+ anEvent wasHandled: true.
+ self mouseLeave: anEvent.
+ ].
+ !
Item was added:
+ ----- Method: Morph>>handleMouseMove: (in category 'events-processing') -----
+ handleMouseMove: anEvent
+ "System level event handling."
+ anEvent wasHandled ifTrue: [ ^ self ].
+ "not interested"
+ (self handlesMouseMove: anEvent) ifFalse: [ ^ self ].
+ anEvent wasHandled: true.
+ self mouseMove: anEvent.
+ (self handlesMouseStillDown: anEvent) ifTrue:
+ [ "Step at the new location"
+ self
+ startStepping: #handleMouseStillDown:
+ at: Time millisecondClockValue
+ arguments: {anEvent copy resetHandlerFields}
+ stepTime: self mouseStillDownStepRate ]!
Item was added:
+ ----- Method: Morph>>handleMouseOver: (in category 'events-processing') -----
+ handleMouseOver: anEvent
+ "System level event handling."
+ anEvent hand mouseFocus == self ifTrue:[
+ "Got this directly through #handleFocusEvent: so check explicitly"
+ (self containsPoint: anEvent position event: anEvent) ifFalse:[^self]].
+ anEvent hand noticeMouseOver: self event: anEvent!
Item was added:
+ ----- Method: Morph>>handleMouseStillDown: (in category 'events-processing') -----
+ handleMouseStillDown: anEvent
+ "Called from the stepping mechanism for morphs wanting continuously repeated 'yes the mouse is still down, yes it is still down, yes it has not changed yet, no the mouse is still not up, yes the button is down' etc messages"
+ (anEvent hand mouseFocus == self)
+ ifFalse:[^self stopSteppingSelector: #handleMouseStillDown:].
+ self mouseStillDown: anEvent.
+ !
Item was added:
+ ----- Method: Morph>>handleMouseUp: (in category 'events-processing') -----
+ handleMouseUp: anEvent
+ "System level event handling."
+ anEvent wasHandled ifTrue:[^self]. "not interested"
+ anEvent hand mouseFocus == self ifFalse:[^self]. "Not interested in other parties"
+ anEvent hand releaseMouseFocus: self.
+ anEvent wasHandled: true.
+ anEvent blueButtonChanged
+ ifTrue:[self blueButtonUp: anEvent]
+ ifFalse:[self mouseUp: anEvent.
+ self stopSteppingSelector: #handleMouseStillDown:].!
Item was added:
+ ----- Method: Morph>>handleUnknownEvent: (in category 'events-processing') -----
+ handleUnknownEvent: anEvent
+ "An event of an unknown type was sent to the receiver. What shall we do?!!"
+ Beeper beep.
+ anEvent printString displayAt: 0 at 0.
+ anEvent wasHandled: true.!
Item was added:
+ ----- Method: Morph>>handleWindowEvent: (in category 'events-processing') -----
+ handleWindowEvent: anEvent
+ "Handle an event concerning our host window"
+ anEvent wasHandled ifTrue:[^self]. "not interested"
+ (self wantsWindowEvent: anEvent) ifFalse:[^self].
+ anEvent wasHandled: true.
+ self windowEvent: anEvent.
+ !
Item was added:
+ ----- Method: Morph>>handlerForBlueButtonDown: (in category 'meta-actions') -----
+ handlerForBlueButtonDown: anEvent
+ "Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event.
+ Note: Halos handle blue button events themselves so we will only be asked if there is currently no halo on top of us."
+ self wantsHaloFromClick ifFalse:[^nil].
+ anEvent handler ifNil:[^self].
+ anEvent handler isPlayfieldLike ifTrue:[^self]. "by default exclude playfields"
+ (anEvent shiftPressed)
+ ifFalse:[^nil] "let outer guy have it"
+ ifTrue:[^self] "let me have it"
+ !
Item was added:
+ ----- Method: Morph>>handlerForMetaMenu: (in category 'meta-actions') -----
+ handlerForMetaMenu: evt
+ "Return the prospective handler for invoking the meta menu. By default, the top-most morph in the innermost world gets this menu"
+ self isWorldMorph ifTrue:[^self].
+ evt handler ifNotNil:[evt handler isWorldMorph ifTrue:[^self]].
+ ^nil!
Item was added:
+ ----- Method: Morph>>handlerForMouseDown: (in category 'event handling') -----
+ handlerForMouseDown: anEvent
+ "Return the (prospective) handler for a mouse down event. The handler is temporarily
+ installed and can be used for morphs further down the hierarchy to negotiate whether
+ the inner or the outer morph should finally handle the event."
+
+ anEvent blueButtonPressed
+ ifTrue: [^ self handlerForBlueButtonDown: anEvent].
+ anEvent yellowButtonPressed
+ ifTrue: [^ self handlerForYellowButtonDown: anEvent].
+ anEvent controlKeyPressed
+ ifTrue: [^ self handlerForMetaMenu: anEvent].
+ (self handlesMouseDown: anEvent)
+ ifFalse: [^ nil]. "not interested"
+
+ anEvent handler
+ ifNil: [^ self ]. "Same priority but I am innermost"
+
+ "Nobody else was interested"
+ ^self mouseDownPriority >= anEvent handler mouseDownPriority
+ ifTrue: [ self]
+ ifFalse: [ nil]!
Item was added:
+ ----- Method: Morph>>handlerForYellowButtonDown: (in category 'event handling') -----
+ handlerForYellowButtonDown: anEvent
+ "Return the (prospective) handler for a mouse down event with the yellow button pressed.
+ The handler is temporarily installed and can be used for morphs further
+ down the hierarchy to negotiate whether the inner or the outer
+ morph should finally handle the event."
+
+ (self hasYellowButtonMenu or: [ self handlesMouseDown: anEvent ])
+ ifFalse: [ ^ nil]. "Not interested."
+
+ anEvent handler
+ ifNil: [^ self]. "Nobody else was interested"
+
+ "Same priority but I am innermost."
+ ^ self mouseDownPriority >= anEvent handler mouseDownPriority
+ ifFalse: [nil ]
+ ifTrue: [self]!
Item was added:
+ ----- Method: Morph>>handlesKeyboard: (in category 'event handling') -----
+ handlesKeyboard: evt
+ "Return true if the receiver wishes to handle the given keyboard event"
+ self eventHandler ifNotNil: [^ self eventHandler handlesKeyboard: evt].
+ ^ false
+ !
Item was added:
+ ----- Method: Morph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ "Do I want to receive mouseDown events (mouseDown:, mouseMove:, mouseUp:)?"
+ "NOTE: The default response is false, except if you have added sensitivity to mouseDown events using the on:send:to: mechanism. Subclasses that implement these messages directly should override this one to return true."
+
+ self eventHandler ifNotNil: [^ self eventHandler handlesMouseDown: evt].
+ ^ false!
Item was added:
+ ----- Method: Morph>>handlesMouseMove: (in category 'event handling') -----
+ handlesMouseMove: anEvent
+ "Do I want to receive mouseMove: when the hand passes over the receiver? Rules say that by default a morph gets #mouseMove iff
+ * the hand is not dragging anything,
+ + and some button is down,
+ + and the receiver is the current mouse focus."
+ anEvent hand hasSubmorphs ifTrue: [ ^ false ].
+ (anEvent anyButtonPressed and: [ anEvent hand mouseFocus == self ]) ifFalse: [ ^ false ].
+ ^ true!
Item was added:
+ ----- Method: Morph>>handlesMouseOver: (in category 'event handling') -----
+ handlesMouseOver: evt
+ "Do I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty? The default response is false, except if you have added sensitivity to mouseEnter: or mouseLeave:, using the on:send:to: mechanism."
+
+ self eventHandler ifNotNil: [^ self eventHandler handlesMouseOver: evt].
+ ^ false!
Item was added:
+ ----- Method: Morph>>handlesMouseOverDragging: (in category 'event handling') -----
+ handlesMouseOverDragging: evt
+ "Return true if I want to receive mouseEnterDragging: and mouseLeaveDragging: when the hand drags something over me (button up or button down), or when the mouse button is down but there is no mouseDown recipient. The default response is false, except if you have added sensitivity to mouseEnterLaden: or mouseLeaveLaden:, using the on:send:to: mechanism."
+ "NOTE: If the hand state matters in these cases, it may be tested by constructs such as
+ event anyButtonPressed
+ event hand hasSubmorphs"
+
+ self eventHandler ifNotNil: [^ self eventHandler handlesMouseOverDragging: evt].
+ ^ false!
Item was added:
+ ----- Method: Morph>>handlesMouseStillDown: (in category 'event handling') -----
+ handlesMouseStillDown: evt
+ "Return true if the receiver wants to get repeated #mouseStillDown: messages between #mouseDown: and #mouseUp"
+ self eventHandler ifNotNil: [^ self eventHandler handlesMouseStillDown: evt].
+ ^ false
+ !
Item was added:
+ ----- Method: Morph>>hasClipLayoutCellsString (in category 'layout-menu') -----
+ hasClipLayoutCellsString
+ ^ (self clipLayoutCells
+ ifTrue: ['<on>']
+ ifFalse: ['<off>']), 'clip to cell size' translated!
Item was added:
+ ----- Method: Morph>>hasClipSubmorphsString (in category 'drawing') -----
+ hasClipSubmorphsString
+ "Answer a string that represents the clip-submophs checkbox"
+ ^ (self clipSubmorphs
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'provide clipping' translated!
Item was added:
+ ----- Method: Morph>>hasDirectionHandlesString (in category 'menus') -----
+ hasDirectionHandlesString
+ ^ (self wantsDirectionHandles
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'direction handles' translated!
Item was added:
+ ----- Method: Morph>>hasDisableTableLayoutString (in category 'layout-menu') -----
+ hasDisableTableLayoutString
+ ^ (self disableTableLayout
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'disable layout in tables' translated!
Item was added:
+ ----- Method: Morph>>hasDocumentAnchorString (in category 'text-anchor') -----
+ hasDocumentAnchorString
+ ^ (self textAnchorType == #document
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'Document' translated!
Item was added:
+ ----- Method: Morph>>hasDragAndDropEnabledString (in category 'menus') -----
+ hasDragAndDropEnabledString
+ "Answer a string to characterize the drag & drop status of the
+ receiver"
+ ^ (self dragNDropEnabled
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'accept drops' translated!
Item was added:
+ ----- Method: Morph>>hasDropShadow (in category 'drop shadows') -----
+ hasDropShadow
+ "answer whether the receiver has DropShadow"
+ ^ self
+ valueOfProperty: #hasDropShadow
+ ifAbsent: [false]!
Item was added:
+ ----- Method: Morph>>hasDropShadow: (in category 'drop shadows') -----
+ hasDropShadow: aBool
+
+ self hasDropShadow = aBool ifTrue: [^ self].
+ self changed.
+ aBool
+ ifTrue:[self setProperty: #hasDropShadow toValue: true]
+ ifFalse:[self removeProperty: #hasDropShadow].
+
+ self layoutChanged.
+ self changed.!
Item was added:
+ ----- Method: Morph>>hasDropShadowString (in category 'drop shadows') -----
+ hasDropShadowString
+ ^ (self hasDropShadow
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'show shadow' translated!
Item was added:
+ ----- Method: Morph>>hasExtension (in category 'accessing - extension') -----
+ hasExtension
+ "answer whether the receiver has extention"
+ ^ extension notNil!
Item was added:
+ ----- Method: Morph>>hasFocus (in category 'event handling') -----
+ hasFocus
+
+ self flag: #obsolete. "mt: Use #hasKeyboardFocus instead, which reads live hand information and no cache."
+ ^ false!
Item was added:
+ ----- Method: Morph>>hasHalo (in category 'halos and balloon help') -----
+ hasHalo
+ ^self hasProperty: #hasHalo.!
Item was added:
+ ----- Method: Morph>>hasHalo: (in category 'halos and balloon help') -----
+ hasHalo: aBool
+ aBool
+ ifTrue:[self setProperty: #hasHalo toValue: true]
+ ifFalse:[self removeProperty: #hasHalo]!
Item was added:
+ ----- Method: Morph>>hasInlineAnchorString (in category 'text-anchor') -----
+ hasInlineAnchorString
+ ^ (self textAnchorType == #inline
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'Inline' translated!
Item was added:
+ ----- Method: Morph>>hasKeyboardFocus (in category 'event handling') -----
+ hasKeyboardFocus
+
+ ^ self activeHand
+ ifNil: [false]
+ ifNotNil: [:hand | self hasKeyboardFocus: hand]!
Item was added:
+ ----- Method: Morph>>hasKeyboardFocus: (in category 'event handling') -----
+ hasKeyboardFocus: aHand
+
+ ^ aHand keyboardFocus == self keyboardFocusDelegate!
Item was added:
+ ----- Method: Morph>>hasMouseFocus (in category 'event handling') -----
+ hasMouseFocus
+
+ ^ self activeHand
+ ifNil: [false]
+ ifNotNil: [:hand | self hasMouseFocus: hand]!
Item was added:
+ ----- Method: Morph>>hasMouseFocus: (in category 'event handling') -----
+ hasMouseFocus: aHand
+
+ ^ aHand mouseFocus == self!
Item was added:
+ ----- Method: Morph>>hasNoLayoutString (in category 'layout-menu') -----
+ hasNoLayoutString
+ ^ (self layoutPolicy isNil
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'no layout' translated!
Item was added:
+ ----- Method: Morph>>hasOwner: (in category 'structure') -----
+ hasOwner: aMorph
+ "Return true if the receiver has aMorph in its owner chain"
+ aMorph ifNil:[^true].
+ self allOwnersDo:[:m| m = aMorph ifTrue:[^true]].
+ ^false!
Item was added:
+ ----- Method: Morph>>hasParagraphAnchorString (in category 'text-anchor') -----
+ hasParagraphAnchorString
+ ^ (self textAnchorType == #paragraph
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'Paragraph' translated!
Item was added:
+ ----- Method: Morph>>hasProperty: (in category 'accessing - properties') -----
+ hasProperty: aSymbol
+ "Answer whether the receiver has the property named aSymbol"
+ extension ifNil: [^ false].
+ ^extension hasProperty: aSymbol!
Item was added:
+ ----- Method: Morph>>hasProportionalLayoutString (in category 'layout-menu') -----
+ hasProportionalLayoutString
+ | layout |
+ ^ (((layout := self layoutPolicy) notNil
+ and: [layout isProportionalLayout])
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'proportional layout' translated!
Item was added:
+ ----- Method: Morph>>hasReverseCellsString (in category 'layout-menu') -----
+ hasReverseCellsString
+ ^ (self reverseTableCells
+ ifTrue: ['<on>']
+ ifFalse: ['<off>']), 'reverse table cells' translated!
Item was added:
+ ----- Method: Morph>>hasRolloverBorder (in category 'drop shadows') -----
+ hasRolloverBorder
+ "answer whether the receiver has RolloverBorder"
+ ^ self
+ valueOfProperty: #hasRolloverBorder
+ ifAbsent: [false]!
Item was added:
+ ----- Method: Morph>>hasRolloverBorder: (in category 'drop shadows') -----
+ hasRolloverBorder: aBool
+ aBool
+ ifTrue:[self setProperty: #hasRolloverBorder toValue: true]
+ ifFalse:[self removeProperty: #hasRolloverBorder]!
Item was added:
+ ----- Method: Morph>>hasRubberBandCellsString (in category 'layout-menu') -----
+ hasRubberBandCellsString
+ ^ (self rubberBandCells
+ ifTrue: ['<on>']
+ ifFalse: ['<off>']), 'rubber band cells' translated!
Item was added:
+ ----- Method: Morph>>hasSubmorphWithProperty: (in category 'submorphs-accessing') -----
+ hasSubmorphWithProperty: aSymbol
+ ^submorphs anySatisfy: [:m | m hasProperty: aSymbol]!
Item was added:
+ ----- Method: Morph>>hasSubmorphs (in category 'submorphs-accessing') -----
+ hasSubmorphs
+ ^submorphs notEmpty!
Item was added:
+ ----- Method: Morph>>hasTableLayoutString (in category 'layout-menu') -----
+ hasTableLayoutString
+ | layout |
+ ^ (((layout := self layoutPolicy) notNil
+ and: [layout isTableLayout])
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'table layout' translated!
Item was added:
+ ----- Method: Morph>>hasTranslucentColor (in category 'accessing') -----
+ hasTranslucentColor
+ "Answer true if this any of this morph is translucent but not transparent."
+
+ ^ color isColor and: [color isTranslucentColor]
+ !
Item was added:
+ ----- Method: Morph>>hasYellowButtonMenu (in category 'menu') -----
+ hasYellowButtonMenu
+ "Answer true if I have any items at all for a context (yellow
+ button) menu."
+ ^ self wantsYellowButtonMenu
+ or: [self models anySatisfy: [:each | each hasModelYellowButtonMenuItems]]!
Item was added:
+ ----- Method: Morph>>height (in category 'geometry') -----
+ height
+
+ ^ bounds height!
Item was added:
+ ----- Method: Morph>>height: (in category 'geometry') -----
+ height: aNumber
+ " Set my height; my position (top-left corner) and width will remain the same "
+
+ self extent: self width at aNumber asInteger.
+ !
Item was added:
+ ----- Method: Morph>>helpButton (in category 'menus') -----
+ helpButton
+ "Answer a button whose action would be to put up help concerning the receiver"
+
+ | aButton |
+ aButton := SimpleButtonMorph new.
+ aButton
+ target: self;
+ color: ColorTheme current helpColor;
+ borderColor: ColorTheme current helpColor muchDarker;
+ borderWidth: 1;
+ label: '?' translated font: Preferences standardButtonFont;
+ actionSelector: #presentHelp;
+ setBalloonText: 'click here for help' translated.
+ ^ aButton!
Item was added:
+ ----- Method: Morph>>hide (in category 'drawing') -----
+ hide
+ owner ifNil: [^ self].
+ self visible ifTrue: [self visible: false. self changed]!
Item was added:
+ ----- Method: Morph>>highlight (in category 'accessing') -----
+ highlight
+ "The receiver is being asked to appear in a highlighted state. Mostly used for textual morphs"
+ self color: self highlightColor!
Item was added:
+ ----- Method: Morph>>highlightColor (in category 'accessing') -----
+ highlightColor
+
+ | val |
+ ^ (val := self valueOfProperty: #highlightColor)
+ ifNotNil:
+ [val ifNil: [self error: 'nil highlightColor']]
+ ifNil:
+ [owner ifNil: [self color] ifNotNil: [owner highlightColor]]!
Item was added:
+ ----- Method: Morph>>highlightColor: (in category 'accessing') -----
+ highlightColor: aColor
+ self setProperty: #highlightColor toValue: aColor!
Item was added:
+ ----- Method: Morph>>highlightForDrop (in category 'dropping/grabbing') -----
+ highlightForDrop
+ self highlightForDrop: true!
Item was added:
+ ----- Method: Morph>>highlightForDrop: (in category 'dropping/grabbing') -----
+ highlightForDrop: aBoolean
+ self setProperty: #highlightedForDrop toValue: aBoolean.
+ self changed!
Item was added:
+ ----- Method: Morph>>highlightForMouseDown (in category 'drawing') -----
+ highlightForMouseDown
+ self highlightForMouseDown: true!
Item was added:
+ ----- Method: Morph>>highlightForMouseDown: (in category 'drawing') -----
+ highlightForMouseDown: aBoolean
+ aBoolean
+ ifTrue:[self setProperty: #highlightedForMouseDown toValue: aBoolean]
+ ifFalse:[self removeProperty: #highlightedForMouseDown. self resetExtension].
+ self changed!
Item was added:
+ ----- Method: Morph>>highlightedForDrop (in category 'dropping/grabbing') -----
+ highlightedForDrop
+ ^(self valueOfProperty: #highlightedForDrop) == true!
Item was added:
+ ----- Method: Morph>>highlightedForMouseDown (in category 'drawing') -----
+ highlightedForMouseDown
+ ^(self valueOfProperty: #highlightedForMouseDown) == true!
Item was added:
+ ----- Method: Morph>>icon (in category 'thumbnail') -----
+ icon
+ "Answer a form with an icon to represent the receiver"
+ ^ self valueOfProperty: #icon!
Item was added:
+ ----- Method: Morph>>iconOrThumbnail (in category 'thumbnail') -----
+ iconOrThumbnail
+ "Answer an appropiate form to represent the receiver"
+
+ ^ self icon
+ ifNil: [ | maxExtent fb |maxExtent := 320 @ 240.
+ fb := self fullBounds.
+ fb area <= (maxExtent x * maxExtent y)
+ ifTrue: [self imageForm]
+ ifFalse: [self imageFormForRectangle: (fb topLeft extent: maxExtent)]
+ ]
+ !
Item was added:
+ ----- Method: Morph>>iconOrThumbnailOfSize: (in category 'thumbnail') -----
+ iconOrThumbnailOfSize: aNumberOrPoint
+ "Answer an appropiate form to represent the receiver"
+
+ ^ self iconOrThumbnail scaledIntoFormOfSize: aNumberOrPoint
+ !
Item was added:
+ ----- Method: Morph>>imageForm (in category 'drawing') -----
+ imageForm
+
+ ^ self imageFormForRectangle: self fullBounds
+ !
Item was added:
+ ----- Method: Morph>>imageForm:backgroundColor:forRectangle: (in category 'drawing') -----
+ imageForm: depth backgroundColor: aColor forRectangle: rect
+ | canvas |
+ canvas := Display defaultCanvasClass extent: rect extent depth: depth.
+ canvas translateBy: rect topLeft negated
+ during:[:tempCanvas|
+ tempCanvas fillRectangle: rect color: aColor.
+ tempCanvas fullDrawMorph: self].
+ ^ canvas form offset: rect topLeft!
Item was added:
+ ----- Method: Morph>>imageForm:forRectangle: (in category 'drawing') -----
+ imageForm: depth forRectangle: rect
+ | canvas |
+ canvas := Display defaultCanvasClass extent: rect extent depth: depth.
+ canvas translateBy: rect topLeft negated
+ during:[:tempCanvas| tempCanvas fullDrawMorph: self].
+ ^ canvas form offset: rect topLeft!
Item was added:
+ ----- Method: Morph>>imageFormDepth: (in category 'drawing') -----
+ imageFormDepth: depth
+
+ ^ self imageForm: depth forRectangle: self fullBounds
+ !
Item was added:
+ ----- Method: Morph>>imageFormForRectangle: (in category 'drawing') -----
+ imageFormForRectangle: rect
+
+ ^ self imageForm: Display depth forRectangle: rect
+ !
Item was added:
+ ----- Method: Morph>>imageFormWithout:andStopThere: (in category 'drawing') -----
+ imageFormWithout: stopMorph andStopThere: stopThere
+ "Like imageForm, except it does not display stopMorph,
+ and it will not display anything above it if stopThere is true.
+ Returns a pair of the imageForm and a boolean that is true
+ if it has hit stopMorph, and display should stop."
+ | canvas rect |
+ rect := self fullBounds.
+ canvas := ColorPatchCanvas extent: rect extent depth: Display depth.
+ canvas stopMorph: stopMorph.
+ canvas doStop: stopThere.
+ canvas translateBy: rect topLeft negated during:[:tempCanvas| tempCanvas fullDrawMorph: self].
+ ^ Array with: (canvas form offset: rect topLeft)
+ with: canvas foundMorph!
Item was added:
+ ----- Method: Morph>>inAScrollPane (in category 'initialization') -----
+ inAScrollPane
+ "Answer a scroll pane that allows the user to scroll the receiver in either direction. It will have permanent scroll bars unless you take some special action."
+
+ | widget |
+ widget := ScrollPane new.
+ widget extent: ((self width min: 300 max: 100) @ (self height min: 150 max: 100));
+ borderWidth: 0.
+ widget scroller addMorph: self.
+ widget setScrollDeltas.
+ widget color: self color darker darker.
+ ^ widget!
Item was added:
+ ----- Method: Morph>>inATwoWayScrollPane (in category 'initialization') -----
+ inATwoWayScrollPane
+ "Answer a two-way scroll pane that allows the user to scroll the receiver in either direction. It will have permanent scroll bars unless you take some special action."
+
+ | widget |
+ widget := TwoWayScrollPane new.
+ widget extent: ((self width min: 300 max: 100) @ (self height min: 150 max: 100));
+ borderWidth: 0.
+ widget scroller addMorph: self.
+ widget setScrollDeltas.
+ widget color: self color darker darker.
+ ^ widget!
Item was added:
+ ----- Method: Morph>>inPartsBin (in category 'parts bin') -----
+ inPartsBin
+
+ self isPartsDonor ifTrue: [^ true].
+ self allOwnersDo: [:m | m isPartsBin ifTrue: [^ true]].
+ ^ false
+ !
Item was added:
+ ----- Method: Morph>>indexOfMorphAbove: (in category 'submorphs-accessing') -----
+ indexOfMorphAbove: aPoint
+ "Return index of lowest morph whose bottom is above aPoint.
+ Will return 0 if the first morph is not above aPoint."
+
+ submorphs withIndexDo: [:mm :ii |
+ mm fullBounds bottom >= aPoint y ifTrue: [^ ii - 1]].
+ ^ submorphs size!
Item was added:
+ ----- Method: Morph>>indicateAllSiblings (in category 'meta-actions') -----
+ indicateAllSiblings
+ "Indicate all the receiver and all its siblings by flashing momentarily."
+
+ | aPlayer allBoxes |
+ (aPlayer := self topRendererOrSelf player) belongsToUniClass ifFalse: [^ self "error: 'not uniclass'"].
+ allBoxes := aPlayer class allInstances
+ select: [:m | m costume world == ActiveWorld]
+ thenCollect: [:m | m costume boundsInWorld].
+
+ 5 timesRepeat:
+ [Display flashAll: allBoxes andWait: 120]!
Item was added:
+ ----- Method: Morph>>indicateKeyboardFocus (in category 'testing') -----
+ indicateKeyboardFocus
+
+ ^ (self hasProperty: #indicateKeyboardFocus)
+ ifTrue: [(self valueOfProperty: #indicateKeyboardFocus) ~~ #never]
+ ifFalse: [self class indicateKeyboardFocus]!
Item was added:
+ ----- Method: Morph>>initString (in category 'printing') -----
+ initString
+
+ ^ String streamContents: [:s | self fullPrintOn: s]!
Item was added:
+ ----- Method: Morph>>initialExtent (in category 'user interface') -----
+ initialExtent
+ | ext |
+ (ext := self valueOfProperty: #initialExtent)
+ ifNotNil:
+ [^ ext].
+ ^ super initialExtent!
Item was added:
+ ----- Method: Morph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ owner := nil.
+ submorphs := Array empty.
+ bounds := self defaultBounds.
+ color := self defaultColor!
Item was added:
+ ----- Method: Morph>>initializeExtension (in category 'accessing - extension') -----
+ initializeExtension
+ "private - initializes the receiver's extension"
+ extension := MorphExtension new!
Item was added:
+ ----- Method: Morph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ "Set up the receiver, created by a #basicNew and now ready to be initialized, as a fully-formed morph suitable for providing a graphic for a parts bin surrogate, and, when such a parts-bin surrogate is clicked on, for attaching to the hand as a viable stand-alone morph. Because of historical precedent, #initialize has been expected to handle this burden, though a great number of morphs actually cannot stand alone. In any case, by default we call the historical #initialize, though unhappily, so that all existing morphs will work no worse than before when using this protocol."
+
+ self initialize!
Item was added:
+ ----- Method: Morph>>innerBounds (in category 'geometry') -----
+ innerBounds
+ "Return the inner rectangle enclosed by the bounds of this morph excluding the space taken by its borders. For an unbordered morph, this is just its bounds."
+
+ ^ self bounds insetBy: self borderWidth!
Item was added:
+ ----- Method: Morph>>innocuousName (in category 'naming') -----
+ innocuousName
+ "Choose an innocuous name for the receiver -- one that does not end in the word Morph"
+
+ | className allKnownNames |
+ className := self defaultNameStemForInstances.
+ (className size > 5 and: [className endsWith: 'Morph'])
+ ifTrue: [className := className copyFrom: 1 to: className size - 5].
+ className := className asString translated.
+ allKnownNames := self world ifNil: [OrderedCollection new] ifNotNil: [self world allKnownNames].
+ ^ Utilities keyLike: className asString satisfying:
+ [:aName | (allKnownNames includes: aName) not]!
Item was added:
+ ----- Method: Morph>>insetColor (in category 'accessing') -----
+ insetColor
+ owner ifNil:[^self color].
+ ^ self colorForInsets!
Item was added:
+ ----- Method: Morph>>inspectArgumentsPlayerInMorphic: (in category 'debug and other') -----
+ inspectArgumentsPlayerInMorphic: evt
+ evt hand attachMorph: ((Inspector openOn: self player) extent: 300 at 200)!
Item was added:
+ ----- Method: Morph>>inspectAt:event: (in category 'meta-actions') -----
+ inspectAt: aPoint event: evt
+ | morphs target |
+ morphs := self morphsAt: aPoint.
+ (morphs includes: self) ifFalse:[morphs := morphs copyWith: self].
+ target := UIManager default
+ chooseFrom: (morphs collect: [:m | m knownName ifNil:[m class name asString]])
+ values: morphs
+ title: ('inspect whom?
+ (deepest at top)').
+ target ifNil:[^self].
+ target inspectInMorphic: evt!
Item was added:
+ ----- Method: Morph>>inspectInMorphic (in category 'menus') -----
+ inspectInMorphic
+
+ ToolSet inspect: self.!
Item was added:
+ ----- Method: Morph>>inspectInMorphic: (in category 'menus') -----
+ inspectInMorphic: evt
+
+ ToolSet inspect: self.
+ !
Item was added:
+ ----- Method: Morph>>inspectOwnerChain (in category 'debug and other') -----
+ inspectOwnerChain
+ self ownerChain inspectWithLabel: 'Owner chain for ', self printString!
Item was added:
+ ----- Method: Morph>>installModelIn: (in category 'debug and other') -----
+ installModelIn: ignored
+ "Simple morphs have no model"
+ "See MorphicApp for other behavior"!
Item was added:
+ ----- Method: Morph>>intersects: (in category 'geometry') -----
+ intersects: aRectangle
+ "Answer whether aRectangle, which is in World coordinates, intersects me."
+
+ ^self fullBoundsInWorld intersects: aRectangle!
Item was added:
+ ----- Method: Morph>>intoWorld: (in category 'initialization') -----
+ intoWorld: aWorld
+ "The receiver has just appeared in a new world. Note:
+ * aWorld can be nil (due to optimizations in other places)
+ * owner is already set
+ * owner's submorphs may not include receiver yet.
+ Important: Keep this method fast - it is run whenever morphs are added."
+ aWorld ifNil:[^self].
+ self wantsSteps ifTrue:[aWorld startStepping: self].
+ self submorphsDo:[:m| m intoWorld: aWorld].
+ !
Item was added:
+ ----- Method: Morph>>invalidRect: (in category 'change reporting') -----
+ invalidRect: damageRect
+ ^self invalidRect: damageRect from: self!
Item was added:
+ ----- Method: Morph>>invalidRect:from: (in category 'change reporting') -----
+ invalidRect: aRectangle from: aMorph
+ | damageRect |
+ aRectangle hasPositiveExtent ifFalse: [ ^self ].
+ damageRect := aRectangle.
+ aMorph == self ifFalse:[
+ "Clip to receiver's clipping bounds if the damage came from a child"
+ self clipSubmorphs
+ ifTrue:[damageRect := aRectangle intersect: self clippingBounds]].
+ owner ifNotNil: [owner invalidRect: damageRect from: self].!
Item was added:
+ ----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') -----
+ invokeMetaMenu: evt
+ | menu |
+ menu := self buildMetaMenu: evt.
+ menu addTitle: self externalName.
+ self world ifNotNil: [
+ menu popUpEvent: evt in: self world
+ ]!
Item was added:
+ ----- Method: Morph>>invokeMetaMenuAt:event: (in category 'meta-actions') -----
+ invokeMetaMenuAt: aPoint event: evt
+ | morphs target |
+ morphs := self morphsAt: aPoint.
+ (morphs includes: self) ifFalse:[morphs := morphs copyWith: self].
+ morphs size = 1 ifTrue:[morphs first invokeMetaMenu: evt].
+ target := UIManager default
+ chooseFrom: (morphs collect: [:m | m knownName ifNil:[m class name asString]])
+ values: morphs.
+ target ifNil:[^self].
+ target invokeMetaMenu: evt!
Item was added:
+ ----- Method: Morph>>isAViewer (in category 'e-toy support') -----
+ isAViewer
+ ^ false!
Item was added:
+ ----- Method: Morph>>isAlignmentMorph (in category 'classification') -----
+ isAlignmentMorph
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>isBalloonHelp (in category 'classification') -----
+ isBalloonHelp
+ ^false!
Item was added:
+ ----- Method: Morph>>isCompoundTileMorph (in category 'classification') -----
+ isCompoundTileMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isDockingBar (in category 'testing') -----
+ isDockingBar
+ "Return true if the receiver is a docking bar"
+ ^ false!
Item was added:
+ ----- Method: Morph>>isFlap (in category 'accessing') -----
+ isFlap
+ "Answer whether the receiver claims to be a flap"
+
+ ^ self hasProperty: #flap!
Item was added:
+ ----- Method: Morph>>isFlapOrTab (in category 'classification') -----
+ isFlapOrTab
+ ^self isFlap or:[self isFlapTab]!
Item was added:
+ ----- Method: Morph>>isFlapTab (in category 'classification') -----
+ isFlapTab
+ ^false!
Item was added:
+ ----- Method: Morph>>isFlexMorph (in category 'classification') -----
+ isFlexMorph
+
+ ^ false
+ !
Item was added:
+ ----- Method: Morph>>isFlexed (in category 'testing') -----
+ isFlexed
+ "Return true if the receiver is currently flexed"
+ owner ifNil:[^false].
+ ^owner isFlexMorph!
Item was added:
+ ----- Method: Morph>>isFullOnScreen (in category 'testing') -----
+ isFullOnScreen
+ "Answer if the receiver is full contained in the owner visible
+ area."
+ owner isInMemory
+ ifFalse: [^ true].
+ owner isNil
+ ifTrue: [^ true].
+ self visible
+ ifFalse: [^ true].
+ ^ owner clearArea containsRect: self fullBounds!
Item was added:
+ ----- Method: Morph>>isGestureStart: (in category 'geniestubs') -----
+ isGestureStart: anEvent
+ "This mouse down could be the start of a gesture, or the end of a gesture focus"
+
+ anEvent hand isGenieEnabled
+ ifFalse: [ ^false ].
+
+ (self allowsGestureStart: anEvent)
+ ifTrue: [^ true ]. "could be the start of a gesture"
+
+ "otherwise, check for whether it's time to disable the Genie auto-focus"
+ (anEvent hand isGenieFocused
+ and: [anEvent whichButton ~= anEvent hand focusStartEvent whichButton])
+ ifTrue: [anEvent hand disableGenieFocus].
+
+ ^false!
Item was added:
+ ----- Method: Morph>>isHandMorph (in category 'classification') -----
+ isHandMorph
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>isImageMorph (in category 'testing') -----
+ isImageMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isInDockingBar (in category 'structure') -----
+ isInDockingBar
+ "answer if the receiver is in a menu bar"
+ ^ (owner notNil) and: [owner isDockingBar]!
Item was added:
+ ----- Method: Morph>>isInSystemWindow (in category 'structure') -----
+ isInSystemWindow
+ "answer if the receiver is in a system window"
+ ^ owner isMorph and:[owner isSystemWindow or:[owner isInSystemWindow]]!
Item was added:
+ ----- Method: Morph>>isInWorld (in category 'structure') -----
+ isInWorld
+ "Return true if this morph is in a world."
+
+ ^self world notNil!
Item was added:
+ ----- Method: Morph>>isKedamaMorph (in category 'classification') -----
+ isKedamaMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isLikelyRecipientForMouseOverHalos (in category 'halos and balloon help') -----
+ isLikelyRecipientForMouseOverHalos
+ ^self player notNil!
Item was added:
+ ----- Method: Morph>>isLineMorph (in category 'testing') -----
+ isLineMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isLocked (in category 'accessing') -----
+ isLocked
+ "answer whether the receiver is Locked"
+ extension ifNil: [^ false].
+ ^ extension locked!
Item was added:
+ ----- Method: Morph>>isModalShell (in category 'classification') -----
+ isModalShell
+ ^false!
Item was added:
+ ----- Method: Morph>>isMorph (in category 'testing') -----
+ isMorph
+
+ ^ true!
Item was added:
+ ----- Method: Morph>>isNumericReadoutTile (in category 'classification') -----
+ isNumericReadoutTile
+ ^false!
Item was added:
+ ----- Method: Morph>>isPartsBin (in category 'parts bin') -----
+ isPartsBin
+ ^ false!
Item was added:
+ ----- Method: Morph>>isPartsDonor (in category 'parts bin') -----
+ isPartsDonor
+ "answer whether the receiver is PartsDonor"
+ extension ifNil: [^ false].
+ ^ extension isPartsDonor!
Item was added:
+ ----- Method: Morph>>isPartsDonor: (in category 'parts bin') -----
+ isPartsDonor: aBoolean
+ "change the receiver's isPartDonor property"
+ (extension isNil and: [aBoolean not]) ifTrue: [^ self].
+ self assureExtension isPartsDonor: aBoolean!
Item was added:
+ ----- Method: Morph>>isPhraseTileMorph (in category 'classification') -----
+ isPhraseTileMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isPlayfieldLike (in category 'classification') -----
+ isPlayfieldLike
+ ^ false!
Item was added:
+ ----- Method: Morph>>isRenderer (in category 'classification') -----
+ isRenderer
+ "A *renderer* morph transforms the appearance of its submorph in some manner. For example, it might supply a drop shadow or scale and rotate the morph it encases. Answer true if this morph acts as a renderer. This default implementation returns false."
+ "Details: A renderer is assumed to have a single submorph. Renderers may be nested to concatenate their transformations. It is useful to be able to find the outer-most renderer. This can be done by ascending the owner chain from the rendered morph. To find the morph being rendered, one can descend through the (singleton) submorph lists of the renderer chain until a non-renderer is encountered."
+
+ ^ false
+ !
Item was added:
+ ----- Method: Morph>>isSafeToServe (in category 'testing') -----
+ isSafeToServe
+ "Return true if it is safe to serve this Morph using Nebraska."
+ ^true!
Item was added:
+ ----- Method: Morph>>isSelectionMorph (in category 'testing') -----
+ isSelectionMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isShared (in category 'accessing') -----
+ isShared
+ "Answer whether the receiver has the #shared property. This property allows it to be treated as a 'background' item"
+
+ ^ self hasProperty: #shared!
Item was added:
+ ----- Method: Morph>>isSketchMorph (in category 'testing') -----
+ isSketchMorph
+ ^self class isSketchMorphClass!
Item was added:
+ ----- Method: Morph>>isSoundTile (in category 'classification') -----
+ isSoundTile
+ ^false!
Item was added:
+ ----- Method: Morph>>isStandardViewer (in category 'classification') -----
+ isStandardViewer
+ ^false!
Item was added:
+ ----- Method: Morph>>isStepping (in category 'stepping and presenter') -----
+ isStepping
+ "Return true if the receiver is currently stepping in its world"
+ | aWorld |
+ ^ (aWorld := self world)
+ ifNil: [false]
+ ifNotNil: [aWorld isStepping: self]!
Item was added:
+ ----- Method: Morph>>isSteppingSelector: (in category 'stepping and presenter') -----
+ isSteppingSelector: aSelector
+ "Return true if the receiver is currently stepping in its world"
+ | aWorld |
+ ^ (aWorld := self world)
+ ifNil: [false]
+ ifNotNil: [aWorld isStepping: self selector: aSelector]!
Item was added:
+ ----- Method: Morph>>isSticky (in category 'accessing') -----
+ isSticky
+ "answer whether the receiver is Sticky"
+ extension ifNil: [^ false].
+ ^ extension sticky!
Item was added:
+ ----- Method: Morph>>isStickySketchMorph (in category 'classification') -----
+ isStickySketchMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isSyntaxMorph (in category 'classification') -----
+ isSyntaxMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isTextMorph (in category 'classification') -----
+ isTextMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isTileEditor (in category 'e-toy support') -----
+ isTileEditor
+ "No, I'm not"
+ ^false!
Item was added:
+ ----- Method: Morph>>isTileMorph (in category 'classification') -----
+ isTileMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isTilePadMorph (in category 'classification') -----
+ isTilePadMorph
+ ^false!
Item was added:
+ ----- Method: Morph>>isViewer (in category 'classification') -----
+ isViewer
+ ^false!
Item was added:
+ ----- Method: Morph>>isWorldMorph (in category 'classification') -----
+ isWorldMorph
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>isWorldOrHandMorph (in category 'classification') -----
+ isWorldOrHandMorph
+
+ ^ self isWorldMorph or: [self isHandMorph]!
Item was added:
+ ----- Method: Morph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: aMorph event: anEvent
+ "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
+
+ | aWindow partsBinCase cmd |
+ (self formerOwner notNil and: [self formerOwner ~~ aMorph])
+ ifTrue: [self removeHalo].
+ self formerOwner: nil.
+ self formerPosition: nil.
+ cmd := self valueOfProperty: #undoGrabCommand.
+ cmd ifNotNil:[aMorph rememberCommand: cmd.
+ self removeProperty: #undoGrabCommand].
+ (partsBinCase := aMorph isPartsBin) ifFalse:
+ [self isPartsDonor: false].
+ (aWindow := aMorph ownerThatIsA: SystemWindow) ifNotNil:
+ [aWindow isActive ifFalse:
+ [aWindow activate]].
+ (self isInWorld and: [partsBinCase not]) ifTrue:
+ [self world startSteppingSubmorphsOf: self].
+ "Note an unhappy inefficiency here: the startStepping... call will often have already been called in the sequence leading up to entry to this method, but unfortunately the isPartsDonor: call often will not have already happened, with the result that the startStepping... call will not have resulted in the startage of the steppage."
+
+ "An object launched by certain parts-launcher mechanisms should end up fully visible..."
+ (self hasProperty: #beFullyVisibleAfterDrop) ifTrue:
+ [aMorph == ActiveWorld ifTrue:
+ [self goHome].
+ self removeProperty: #beFullyVisibleAfterDrop].
+ !
Item was added:
+ ----- Method: Morph>>justDroppedIntoPianoRoll:event: (in category '*Morphic-Sound-piano rolls') -----
+ justDroppedIntoPianoRoll: pianoRoll event: evt
+
+ | ambientEvent startTimeInScore |
+ startTimeInScore := pianoRoll timeForX: self left.
+
+ ambientEvent := AmbientEvent new
+ morph: self;
+ time: startTimeInScore.
+
+ pianoRoll score addAmbientEvent: ambientEvent.
+
+ "self endTime > pianoRoll scorePlayer durationInTicks ifTrue:
+ [pianoRoll scorePlayer updateDuration]"
+ !
Item was added:
+ ----- Method: Morph>>justGrabbedFrom: (in category 'dropping/grabbing') -----
+ justGrabbedFrom: formerOwner
+ "The receiver was just grabbed from its former owner and is now attached to the hand. By default, we pass this message on if we're a renderer."
+ (self isRenderer and:[self hasSubmorphs])
+ ifTrue:[self firstSubmorph justGrabbedFrom: formerOwner].!
Item was added:
+ ----- Method: Morph>>keepsTransform (in category 'rotate scale and flex') -----
+ keepsTransform
+ "Return true if the receiver will keep it's transform while being grabbed by a hand."
+ ^false!
Item was added:
+ ----- Method: Morph>>keyDown: (in category 'event handling') -----
+ keyDown: anEvent
+ "Handle a key down event. The default response is to do nothing."!
Item was added:
+ ----- Method: Morph>>keyStroke: (in category 'event handling') -----
+ keyStroke: anEvent
+ "Handle a keystroke event. The default response is to let my eventHandler, if any, handle it."
+
+ self eventHandler ifNotNil:
+ [self eventHandler keyStroke: anEvent fromMorph: self].
+ !
Item was added:
+ ----- Method: Morph>>keyUp: (in category 'event handling') -----
+ keyUp: anEvent
+ "Handle a key up event. The default response is to do nothing."!
Item was added:
+ ----- Method: Morph>>keyboardFocusChange: (in category 'event handling') -----
+ keyboardFocusChange: aBoolean
+ "The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining keyboard focus (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus. This default implementation does nothing."
+
+ self indicateKeyboardFocus ifTrue: [self changed].!
Item was added:
+ ----- Method: Morph>>keyboardFocusColor (in category 'drawing') -----
+ keyboardFocusColor
+
+ ^ Preferences keyboardFocusColor muchDarker alpha: 0.5!
Item was added:
+ ----- Method: Morph>>keyboardFocusDelegate (in category 'event handling') -----
+ keyboardFocusDelegate
+ "If this morph ever tries to acquire the keyboard focus, this can be delegate to, for example, a submorph."
+
+ ^ self!
Item was added:
+ ----- Method: Morph>>knownName (in category 'testing') -----
+ knownName
+ "answer a name by which the receiver is known, or nil if none"
+ ^ extension ifNotNil: [extension externalName]!
Item was added:
+ ----- Method: Morph>>lastSubmorph (in category 'submorphs-accessing') -----
+ lastSubmorph
+ ^submorphs last!
Item was added:
+ ----- Method: Morph>>layoutBounds (in category 'layout') -----
+ layoutBounds
+ "Return the bounds for laying out children of the receiver"
+ | inset box |
+ inset := self layoutInset.
+ box := self innerBounds.
+ inset isZero ifTrue:[^box].
+ ^box insetBy: inset.!
Item was added:
+ ----- Method: Morph>>layoutBounds: (in category 'layout') -----
+ layoutBounds: aRectangle
+ "Set the bounds for laying out children of the receiver.
+ Note: written so that #layoutBounds can be changed without touching this method"
+ | priorBounds outer inner box |
+ priorBounds := self outerBounds.
+ outer := self bounds.
+ inner := self layoutBounds.
+ bounds := aRectangle origin + (outer origin - inner origin) corner:
+ aRectangle corner + (outer corner - inner corner).
+ self removeProperty: #dropShadow.
+ box := self outerBounds.
+ box = priorBounds
+ ifFalse: [self invalidRect: (priorBounds quickMerge: box)]!
Item was added:
+ ----- Method: Morph>>layoutChanged (in category 'layout') -----
+ layoutChanged
+ | layout |
+ fullBounds ifNil:[^self]. "layout will be recomputed so don't bother"
+ fullBounds := nil.
+ layout := self layoutPolicy.
+ layout ifNotNil:[layout flushLayoutCache].
+ owner ifNotNil: [owner layoutChanged].
+ "note: does not send #ownerChanged here - we'll do this when computing the new layout"!
Item was added:
+ ----- Method: Morph>>layoutFrame (in category 'layout-properties') -----
+ layoutFrame
+ "Layout specific. Return the layout frame describing where the
+ receiver should appear in a proportional layout"
+ ^ extension ifNotNil: [extension layoutFrame]!
Item was added:
+ ----- Method: Morph>>layoutFrame: (in category 'layout-properties') -----
+ layoutFrame: aLayoutFrame
+ "Layout specific. Return the layout frame describing where the receiver should appear in a proportional layout"
+ self layoutFrame == aLayoutFrame ifTrue:[^self].
+ self assureExtension layoutFrame: aLayoutFrame.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>layoutInBounds: (in category 'layout') -----
+ layoutInBounds: cellBounds
+ "Layout specific. Apply the given bounds to the receiver after being layed out in its owner."
+ | box aSymbol delta |
+ fullBounds ifNil:["We are getting new bounds here but we haven't computed the receiver's layout yet. Although the receiver has reported its minimal size before the actual size it has may differ from what would be after the layout. Normally, this isn't a real problem, but if we have #shrinkWrap constraints then the receiver's bounds may be larger than the cellBounds. THAT is a problem because the centering may not work correctly if the receiver shrinks after the owner layout has been computed. To avoid this problem, we compute the receiver's layout now. Note that the layout computation is based on the new cell bounds rather than the receiver's current bounds."
+ cellBounds origin = self bounds origin ifFalse:[
+ box := self outerBounds.
+ delta := cellBounds origin - self bounds origin.
+ self invalidRect: (box merge: (box translateBy: delta)).
+ self privateFullMoveBy: delta]. "sigh..."
+ box := cellBounds origin extent: "adjust for #rigid receiver"
+ (self hResizing == #rigid ifTrue:[self bounds extent x] ifFalse:[cellBounds extent x]) @
+ (self vResizing == #rigid ifTrue:[self bounds extent y] ifFalse:[cellBounds extent y]).
+ "Compute inset of layout bounds"
+ box := box origin - (self bounds origin - self layoutBounds origin) corner:
+ box corner - (self bounds corner - self layoutBounds corner).
+ "And do the layout within the new bounds"
+ self layoutBounds: box.
+ self doLayoutIn: box].
+ cellBounds = self fullBounds ifTrue:[^self]. "already up to date"
+ cellBounds extent = self fullBounds extent "nice fit"
+ ifTrue:[^self position: cellBounds origin].
+ box := bounds.
+ "match #spaceFill constraints"
+ self hResizing == #spaceFill
+ ifTrue:[box := box origin extent: cellBounds width @ box height].
+ self vResizing == #spaceFill
+ ifTrue:[box := box origin extent: box width @ cellBounds height].
+ "align accordingly"
+ aSymbol := (owner ifNil:[self]) cellPositioning.
+ box := box align: (box perform: aSymbol) with: (cellBounds perform: aSymbol).
+ "and install new bounds"
+ self bounds: box.!
Item was added:
+ ----- Method: Morph>>layoutInset (in category 'layout-properties') -----
+ layoutInset
+ "Return the extra inset for layouts"
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[0] ifNotNil:[props layoutInset].!
Item was added:
+ ----- Method: Morph>>layoutInset: (in category 'layout-properties') -----
+ layoutInset: aNumber
+ "Return the extra inset for layouts"
+ self assureTableProperties layoutInset: aNumber.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>layoutMenuPropertyString:from: (in category 'layout-menu') -----
+ layoutMenuPropertyString: aSymbol from: currentSetting
+ | onOff wording |
+ onOff := aSymbol == currentSetting
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'].
+ ""
+ wording := String
+ streamContents: [:stream |
+ | index |
+ index := 1.
+ aSymbol
+ keysAndValuesDo: [:idx :ch | ch isUppercase
+ ifTrue: [""stream nextPutAll: (aSymbol copyFrom: index to: idx - 1) asLowercase.
+ stream nextPutAll: ' '.
+ index := idx]].
+ index < aSymbol size
+ ifTrue: [stream nextPutAll: (aSymbol copyFrom: index to: aSymbol size) asLowercase]].
+ ""
+ ^ onOff , wording translated!
Item was added:
+ ----- Method: Morph>>layoutPolicy (in category 'layout-properties') -----
+ layoutPolicy
+ "Layout specific. Return the layout policy describing how children
+ of the receiver should appear."
+ ^ extension ifNotNil: [ extension layoutPolicy]!
Item was added:
+ ----- Method: Morph>>layoutPolicy: (in category 'layout-properties') -----
+ layoutPolicy: aLayoutPolicy
+ "Layout specific. Return the layout policy describing how children of the receiver should appear."
+ self layoutPolicy == aLayoutPolicy ifTrue:[^self].
+ self assureExtension layoutPolicy: aLayoutPolicy.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>layoutProperties (in category 'layout-properties') -----
+ layoutProperties
+ "Return the current layout properties associated with the
+ receiver"
+ ^ extension ifNotNil: [ extension layoutProperties]!
Item was added:
+ ----- Method: Morph>>layoutProperties: (in category 'layout-properties') -----
+ layoutProperties: newProperties
+ "Return the current layout properties associated with the receiver"
+ self layoutProperties == newProperties ifTrue:[^self].
+ self assureExtension layoutProperties: newProperties.
+ !
Item was added:
+ ----- Method: Morph>>layoutProportionallyIn: (in category 'layout') -----
+ layoutProportionallyIn: newBounds
+ "Layout specific. Apply the given bounds to the receiver."
+ | box frame |
+ frame := self layoutFrame ifNil:[^self].
+ "before applying the proportional values make sure the receiver's layout is computed"
+ self fullBounds. "sigh..."
+ "compute the cell size the receiver has given its layout frame"
+ box := frame layout: self bounds in: newBounds.
+ (box = self bounds) ifTrue:[^self]. "no change"
+ ^self layoutInBounds: box.!
Item was added:
+ ----- Method: Morph>>left (in category 'geometry') -----
+ left
+ " Return the x-coordinate of my left side "
+
+ ^ bounds left!
Item was added:
+ ----- Method: Morph>>left: (in category 'geometry') -----
+ left: aNumber
+ " Move me so that my left side is at the x-coordinate aNumber. My extent (width & height) are unchanged "
+
+ self position: (aNumber @ bounds top)!
Item was added:
+ ----- Method: Morph>>leftCenter (in category 'geometry') -----
+ leftCenter
+
+ ^ bounds leftCenter!
Item was added:
+ ----- Method: Morph>>listCentering (in category 'layout-properties') -----
+ listCentering
+ "Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
+ #topLeft - center at start of primary direction
+ #bottomRight - center at end of primary direction
+ #center - center in the middle of primary direction
+ #justified - insert extra space inbetween rows/columns
+ "
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#topLeft] ifNotNil:[props listCentering].!
Item was added:
+ ----- Method: Morph>>listCentering: (in category 'layout-properties') -----
+ listCentering: aSymbol
+ "Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
+ #topLeft - center at start of primary direction
+ #bottomRight - center at end of primary direction
+ #center - center in the middle of primary direction
+ #justified - insert extra space inbetween rows/columns
+ "
+ self assureTableProperties listCentering: aSymbol.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>listCenteringString: (in category 'layout-properties') -----
+ listCenteringString: aSymbol
+ ^self layoutMenuPropertyString: aSymbol from: self listCentering!
Item was added:
+ ----- Method: Morph>>listDirection (in category 'layout-properties') -----
+ listDirection
+ "Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are:
+ #leftToRight
+ #rightToLeft
+ #topToBottom
+ #bottomToTop
+ indicating the direction in which any layout should take place"
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#topToBottom] ifNotNil:[props listDirection].!
Item was added:
+ ----- Method: Morph>>listDirection: (in category 'layout-properties') -----
+ listDirection: aSymbol
+ "Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are:
+ #leftToRight
+ #rightToLeft
+ #topToBottom
+ #bottomToTop
+ indicating the direction in which any layout should take place"
+ self assureTableProperties listDirection: aSymbol.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>listDirectionString: (in category 'layout-properties') -----
+ listDirectionString: aSymbol
+ ^self layoutMenuPropertyString: aSymbol from: self listDirection!
Item was added:
+ ----- Method: Morph>>listSpacing (in category 'layout-properties') -----
+ listSpacing
+ "Layout specific. This property describes how the heights for different rows in a table layout should be handled.
+ #equal - all rows have the same height
+ #none - all rows may have different heights
+ "
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#none] ifNotNil:[props listSpacing].!
Item was added:
+ ----- Method: Morph>>listSpacing: (in category 'layout-properties') -----
+ listSpacing: aSymbol
+ "Layout specific. This property describes how the heights for different rows in a table layout should be handled.
+ #equal - all rows have the same height
+ #none - all rows may have different heights
+ "
+ self assureTableProperties listSpacing: aSymbol.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>listSpacingString: (in category 'layout-properties') -----
+ listSpacingString: aSymbol
+ ^self layoutMenuPropertyString: aSymbol from: self listSpacing!
Item was added:
+ ----- Method: Morph>>loadCachedState (in category 'caching') -----
+ loadCachedState
+ "Load the cached state of this morph. This method may be called to pre-load the cached state of a morph to avoid delays when it is first used. (Cached state can always be recompued on demand, so a morph should not rely on this method being called.) Implementations of this method should do 'super loadCachedState'. This default implementation does nothing."
+ !
Item was added:
+ ----- Method: Morph>>localPointToGlobal: (in category 'geometry') -----
+ localPointToGlobal: aPoint
+ ^self point: aPoint in: nil!
Item was added:
+ ----- Method: Morph>>lock (in category 'accessing') -----
+ lock
+ self lock: true!
Item was added:
+ ----- Method: Morph>>lock: (in category 'accessing') -----
+ lock: aBoolean
+ "change the receiver's lock property"
+ (extension isNil and: [aBoolean not]) ifTrue: [^ self].
+ self assureExtension locked: aBoolean!
Item was added:
+ ----- Method: Morph>>lockUnlockMorph (in category 'menus') -----
+ lockUnlockMorph
+ "If the receiver is locked, unlock it; if unlocked, lock it"
+
+ self isLocked ifTrue: [self unlock] ifFalse: [self lock]!
Item was added:
+ ----- Method: Morph>>lockedString (in category 'menus') -----
+ lockedString
+ "Answer the string to be shown in a menu to represent the
+ 'locked' status"
+ ^ (self isLocked
+ ifTrue: ['<on>']
+ ifFalse: ['<off>']), 'be locked' translated!
Item was added:
+ ----- Method: Morph>>mainDockingBars (in category 'submorphs-accessing') -----
+ mainDockingBars
+ "Answer the receiver's main dockingBars"
+ ^ self dockingBars
+ select: [:each | each hasProperty: #mainDockingBarTimeStamp]!
Item was added:
+ ----- Method: Morph>>makeGraphPaper (in category 'e-toy support') -----
+ makeGraphPaper
+ | smallGrid backColor lineColor |
+ smallGrid := Compiler evaluate: (UIManager default request: 'Enter grid size' translated initialAnswer: '16').
+ smallGrid ifNil: [^ self].
+ UIManager default informUser: 'Choose a background color' translated during: [backColor := Color fromUser].
+ UIManager default informUser: 'Choose a line color' translated during: [lineColor := Color fromUser].
+ self makeGraphPaperGrid: smallGrid background: backColor line: lineColor.!
Item was added:
+ ----- Method: Morph>>makeGraphPaperGrid:background:line: (in category 'e-toy support') -----
+ makeGraphPaperGrid: smallGrid background: backColor line: lineColor
+
+ | gridForm |
+ gridForm := self gridFormOrigin: 0 at 0 grid: smallGrid asPoint background: backColor line: lineColor.
+ self color: gridForm.
+ self world ifNotNil: [self world fullRepaintNeeded].
+ self changed: #newColor. "propagate to view"
+ !
Item was added:
+ ----- Method: Morph>>makeMultipleSiblings: (in category 'meta-actions') -----
+ makeMultipleSiblings: evt
+ "Make multiple siblings, first prompting the user for how many"
+
+ | result |
+ self topRendererOrSelf couldMakeSibling ifFalse: [^ Beeper beep].
+ result := UIManager default request: 'how many siblings do you want?' translated initialAnswer: '2'.
+ result isEmptyOrNil ifTrue: [^ self].
+ result first isDigit ifFalse: [^ Beeper beep].
+ self topRendererOrSelf makeSiblings: result asInteger.!
Item was added:
+ ----- Method: Morph>>makeNascentScript (in category 'menus') -----
+ makeNascentScript
+ ^ self notYetImplemented!
Item was added:
+ ----- Method: Morph>>makeNewPlayerInstance: (in category 'meta-actions') -----
+ makeNewPlayerInstance: evt
+ "Make a duplicate of the receiver's argument. This is called only where the argument has an associated Player as its costumee, and the intent here is to make another instance of the same uniclass as the donor Player itself. Much works, but there are flaws so this shouldn't be used without recognizing the risks"
+
+ evt hand attachMorph: self usableSiblingInstance!
Item was added:
+ ----- Method: Morph>>makeSiblings: (in category 'meta-actions') -----
+ makeSiblings: count
+ "Make multiple sibling, and return the list"
+
+ | listOfNewborns aPosition |
+ aPosition := self position.
+ listOfNewborns := (1 to: count asInteger) asArray collect:
+ [:anIndex | | anInstance |
+ anInstance := self usableSiblingInstance.
+ owner addMorphFront: anInstance.
+ aPosition := aPosition + (10 at 10).
+ anInstance position: aPosition.
+ anInstance].
+ self currentWorld startSteppingSubmorphsOf: self topRendererOrSelf owner.
+ ^ listOfNewborns!
Item was added:
+ ----- Method: Morph>>makeSiblingsLookLikeMe: (in category 'meta-actions') -----
+ makeSiblingsLookLikeMe: evt
+ "Make all my siblings wear the same costume that I am wearing."
+
+ | aPlayer |
+ (aPlayer := self topRendererOrSelf player) belongsToUniClass ifFalse: [self error: 'not uniclass'].
+ aPlayer class allInstancesDo:
+ [:anInstance | anInstance == aPlayer ifFalse:
+ [anInstance wearCostumeOf: aPlayer]]!
Item was added:
+ ----- Method: Morph>>markAsPartsDonor (in category 'parts bin') -----
+ markAsPartsDonor
+ "Mark the receiver specially so that mouse actions on it are interpreted as 'tearing off a copy'"
+
+ self isPartsDonor: true!
Item was added:
+ ----- Method: Morph>>maxCellSize (in category 'layout-properties') -----
+ maxCellSize
+ "Layout specific. This property specifies the maximum size of a table cell."
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[SmallInteger maxVal] ifNotNil:[props maxCellSize].!
Item was added:
+ ----- Method: Morph>>maxCellSize: (in category 'layout-properties') -----
+ maxCellSize: aPoint
+ "Layout specific. This property specifies the maximum size of a table cell."
+ self assureTableProperties maxCellSize: aPoint.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>maybeAddCollapseItemTo: (in category 'menus') -----
+ maybeAddCollapseItemTo: aMenu
+ "If appropriate, add a collapse item to the given menu"
+
+ | anOwner |
+ (anOwner := self topRendererOrSelf owner) ifNotNil:
+ [anOwner isWorldMorph ifTrue:
+ [aMenu add: 'collapse' translated target: self action: #collapse]]!
Item was added:
+ ----- Method: Morph>>maybeDuplicateMorph (in category 'meta-actions') -----
+ maybeDuplicateMorph
+ "Maybe duplicate the morph"
+
+ self okayToDuplicate ifTrue:
+ [self topRendererOrSelf duplicate openInHand]!
Item was added:
+ ----- Method: Morph>>maybeDuplicateMorph: (in category 'meta-actions') -----
+ maybeDuplicateMorph: evt
+ self okayToDuplicate ifTrue:[^self duplicateMorph: evt]!
Item was added:
+ ----- Method: Morph>>menuButtonMouseEnter: (in category 'other events') -----
+ menuButtonMouseEnter: event
+ "The mouse entered a menu-button area; show the menu cursor temporarily"
+
+ event hand showTemporaryCursor: Cursor menu!
Item was added:
+ ----- Method: Morph>>menuButtonMouseLeave: (in category 'other events') -----
+ menuButtonMouseLeave: event
+ "The mouse left a menu-button area; restore standard cursor"
+
+ event hand showTemporaryCursor: nil!
Item was added:
+ ----- Method: Morph>>menuItemAfter: (in category 'menus') -----
+ menuItemAfter: menuString
+ | allWordings |
+ allWordings := self allMenuWordings.
+ ^ allWordings atWrap: ((allWordings indexOf: menuString) + 1)!
Item was added:
+ ----- Method: Morph>>menuItemBefore: (in category 'menus') -----
+ menuItemBefore: menuString
+ | allWordings |
+ allWordings := self allMenuWordings.
+ ^ allWordings atWrap: ((allWordings indexOf: menuString) - 1)!
Item was added:
+ ----- Method: Morph>>methodCommentAsBalloonHelp (in category 'accessing') -----
+ methodCommentAsBalloonHelp
+ "Given that I am a morph that is associated with an object and a method, answer a suitable method comment relating to that object & method if possible"
+
+ | inherentSelector actual |
+ (inherentSelector := self valueOfProperty: #inherentSelector)
+ ifNotNil:
+ [(actual := (self firstOwnerSuchThat:[:m| m isPhraseTileMorph or:[m isSyntaxMorph]]) actualObject) ifNotNil:
+ [^ actual class precodeCommentOrInheritedCommentFor: inherentSelector]].
+ ^ nil!
Item was added:
+ ----- Method: Morph>>minCellSize (in category 'layout-properties') -----
+ minCellSize
+ "Layout specific. This property specifies the minimal size of a table cell."
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[0] ifNotNil:[props minCellSize].!
Item was added:
+ ----- Method: Morph>>minCellSize: (in category 'layout-properties') -----
+ minCellSize: aPoint
+ "Layout specific. This property specifies the minimal size of a table cell."
+ self assureTableProperties minCellSize: aPoint.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>minExtent (in category 'layout') -----
+ minExtent
+ "Layout specific. Return the minimum size the receiver can be represented in.
+ Implementation note: When this message is sent from an owner trying to lay out its children it will traverse down the morph tree and recompute the minimal arrangement of the morphs based on which the minimal extent is returned. When a morph with some layout strategy is encountered, the morph will ask its strategy to compute the new arrangement. However, since the final size given to the receiver is unknown at the point of the query, the assumption is made that the current bounds of the receiver are the base on which the layout should be computed. This scheme prevents strange layout changes when for instance, a table is contained in another table. Unless the inner table has been resized manually (which means its bounds are already enlarged) the arrangement of the inner table will not change here. Thus the entire layout computation is basically an iterative process which may have different results depending on the incremental changes applied."
+
+ | layout minExtent extra hFit vFit |
+ hFit := self hResizing.
+ vFit := self vResizing.
+ (hFit == #spaceFill or: [vFit == #spaceFill])
+ ifFalse:
+ ["The receiver will not adjust to parents layout by growing or shrinking,
+ which means that an accurate layout defines the minimum size."
+
+ ^self fullBounds extent].
+
+ "An exception -- a receiver with #shrinkWrap constraints but no children is being treated #rigid (the equivalent to a #spaceFill receiver in a non-layouting owner)"
+ self hasSubmorphs
+ ifFalse:
+ [hFit == #shrinkWrap ifTrue: [hFit := #rigid].
+ vFit == #shrinkWrap ifTrue: [vFit := #rigid]].
+ layout := self layoutPolicy.
+ layout isNil
+ ifTrue: [minExtent := 0 @ 0]
+ ifFalse: [minExtent := layout minExtentOf: self in: self layoutBounds].
+ hFit == #rigid
+ ifTrue: [minExtent := self fullBounds extent x @ minExtent y]
+ ifFalse:
+ [extra := self bounds width - self layoutBounds width.
+ minExtent := (minExtent x + extra) @ minExtent y].
+ minExtent := vFit == #rigid
+ ifTrue: [minExtent x @ self fullBounds extent y]
+ ifFalse:
+ [extra := self bounds height - self layoutBounds height.
+ minExtent x @ (minExtent y + extra)].
+ minExtent := minExtent max: self minWidth @ self minHeight.
+ ^minExtent!
Item was added:
+ ----- Method: Morph>>minHeight (in category 'layout') -----
+ minHeight
+ "answer the receiver's minHeight"
+ ^ self
+ valueOfProperty: #minHeight
+ ifAbsent: [2]!
Item was added:
+ ----- Method: Morph>>minHeight: (in category 'layout') -----
+ minHeight: aNumber
+ aNumber isNil
+ ifTrue: [self removeProperty: #minHeight]
+ ifFalse: [self setProperty: #minHeight toValue: aNumber].
+ self layoutChanged!
Item was added:
+ ----- Method: Morph>>minWidth (in category 'layout') -----
+ minWidth
+ "answer the receiver's minWidth"
+ ^ self
+ valueOfProperty: #minWidth
+ ifAbsent: [2]!
Item was added:
+ ----- Method: Morph>>minWidth: (in category 'layout') -----
+ minWidth: aNumber
+ aNumber isNil
+ ifTrue: [self removeProperty: #minWidth]
+ ifFalse: [self setProperty: #minWidth toValue: aNumber].
+ self layoutChanged!
Item was added:
+ ----- Method: Morph>>minimumExtent (in category 'geometry') -----
+ minimumExtent
+ | ext |
+ "This returns the minimum extent that the morph may be shrunk to. Not honored in too many places yet, but respected by the resizeToFit feature, at least. copied up from SystemWindow 6/00"
+ (ext := self valueOfProperty: #minimumExtent)
+ ifNotNil:
+ [^ ext].
+ ^ 100 @ 80!
Item was added:
+ ----- Method: Morph>>minimumExtent: (in category 'geometry') -----
+ minimumExtent: aPoint
+ "Remember a minimumExtent, for possible future use"
+
+ self setProperty: #minimumExtent toValue: aPoint
+ !
Item was added:
+ ----- Method: Morph>>modalLockTo: (in category 'polymorph') -----
+ modalLockTo: aSystemWindow
+ "Lock the receiver as a modal owner of the given window."
+
+ self lock!
Item was added:
+ ----- Method: Morph>>modalUnlockFrom: (in category 'polymorph') -----
+ modalUnlockFrom: aSystemWindow
+ "Unlock the receiver as a modal owner of the given window."
+
+ self unlock!
Item was added:
+ ----- Method: Morph>>model (in category 'menus') -----
+ model
+ ^ nil !
Item was added:
+ ----- Method: Morph>>modelOrNil (in category 'accessing') -----
+ modelOrNil
+ ^ nil!
Item was added:
+ ----- Method: Morph>>models (in category 'model access') -----
+ models
+ "Answer a collection of whatever models I may have."
+ ^ self modelOrNil
+ ifNil: [ Array empty ]
+ ifNotNil: [ Array with: self modelOrNil ]!
Item was added:
+ ----- Method: Morph>>modificationHash (in category 'testing') -----
+ modificationHash
+
+ ^String
+ streamContents: [ :strm |
+ self longPrintOn: strm
+ ]
+ limitedTo: 25
+ !
Item was added:
+ ----- Method: Morph>>morphPreceding: (in category 'structure') -----
+ morphPreceding: aSubmorph
+ "Answer the morph immediately preceding aSubmorph, or nil if none"
+
+ | anIndex |
+ anIndex := submorphs indexOf: aSubmorph ifAbsent: [^ nil].
+ ^ anIndex > 1
+ ifTrue:
+ [submorphs at: (anIndex - 1)]
+ ifFalse:
+ [nil]!
Item was added:
+ ----- Method: Morph>>morphReport (in category 'printing') -----
+ morphReport
+
+ ^self morphReportFor: #(hResizing vResizing bounds)!
Item was added:
+ ----- Method: Morph>>morphReportFor: (in category 'printing') -----
+ morphReportFor: attributeList
+
+ | s |
+
+ s := WriteStream on: String new.
+ self
+ morphReportFor: attributeList
+ on: s
+ indent: 0.
+ StringHolder new contents: s contents; openLabel: 'morph report'!
Item was added:
+ ----- Method: Morph>>morphReportFor:on:indent: (in category 'printing') -----
+ morphReportFor: attributeList on: aStream indent: anInteger
+
+ anInteger timesRepeat: [aStream tab].
+ aStream print: self; space.
+ attributeList do: [ :a | aStream print: (self perform: a); space].
+ aStream cr.
+ submorphs do: [ :sub |
+ sub morphReportFor: attributeList on: aStream indent: anInteger + 1
+ ].!
Item was added:
+ ----- Method: Morph>>morphRepresented (in category 'thumbnail') -----
+ morphRepresented
+ "If the receiver is an alias, answer the morph it represents; else answer self"
+
+ ^ self!
Item was added:
+ ----- Method: Morph>>morphToDropInPasteUp: (in category 'dropping/grabbing') -----
+ morphToDropInPasteUp: aPasteUp
+ ^ self!
Item was added:
+ ----- Method: Morph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+
+ "helpful for insuring some morphs always appear in front of or behind others.
+ smaller numbers are in front"
+
+ ^(owner isNil or: [owner isWorldMorph]) ifTrue: [
+ self valueOfProperty: #morphicLayerNumber ifAbsent: [100]
+ ] ifFalse: [
+ owner morphicLayerNumber
+ ].
+
+ "leave lots of room for special things"!
Item was added:
+ ----- Method: Morph>>morphicLayerNumberWithin: (in category 'WiW support') -----
+ morphicLayerNumberWithin: anOwner
+
+ "helpful for insuring some morphs always appear in front of or behind others.
+ smaller numbers are in front"
+
+ ^(owner isNil or: [owner isWorldMorph or: [anOwner == owner]]) ifTrue: [
+ self valueOfProperty: #morphicLayerNumber ifAbsent: [100]
+ ] ifFalse: [
+ owner morphicLayerNumber
+ ].
+
+ "leave lots of room for special things"!
Item was added:
+ ----- Method: Morph>>morphsAt: (in category 'submorphs-accessing') -----
+ morphsAt: aPoint
+ "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. The order is deepest embedding first."
+ ^self morphsAt: aPoint unlocked: false!
Item was added:
+ ----- Method: Morph>>morphsAt:behind:unlocked: (in category 'submorphs-accessing') -----
+ morphsAt: aPoint behind: aMorph unlocked: aBool
+ "Return all morphs at aPoint that are behind frontMorph; if aBool is true return only unlocked, visible morphs."
+
+ | isBack all tfm |
+ all := (aMorph isNil or: [owner isNil])
+ ifTrue:
+ ["Traverse down"
+
+ (self fullBounds containsPoint: aPoint) ifFalse: [^#()].
+ (aBool and: [self isLocked or: [self visible not]]) ifTrue: [^#()].
+ nil]
+ ifFalse:
+ ["Traverse up"
+
+ tfm := self transformedFrom: owner.
+ all := owner
+ morphsAt: (tfm localPointToGlobal: aPoint)
+ behind: self
+ unlocked: aBool.
+ WriteStream with: all].
+ isBack := aMorph isNil.
+ self submorphsDo:
+ [:m | | found |
+ isBack
+ ifTrue:
+ [tfm := m transformedFrom: self.
+ found := m
+ morphsAt: (tfm globalPointToLocal: aPoint)
+ behind: nil
+ unlocked: aBool.
+ found notEmpty
+ ifTrue:
+ [all ifNil: [all := WriteStream on: #()].
+ all nextPutAll: found]].
+ m == aMorph ifTrue: [isBack := true]].
+ (isBack and: [self containsPoint: aPoint])
+ ifTrue:
+ [all ifNil: [^Array with: self].
+ all nextPut: self].
+ ^all ifNil: [#()] ifNotNil: [all contents]!
Item was added:
+ ----- Method: Morph>>morphsAt:unlocked: (in category 'submorphs-accessing') -----
+ morphsAt: aPoint unlocked: aBool
+ "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. The order is deepest embedding first."
+ | mList |
+ mList := WriteStream on: #().
+ self morphsAt: aPoint unlocked: aBool do:[:m| mList nextPut: m].
+ ^mList contents!
Item was added:
+ ----- Method: Morph>>morphsAt:unlocked:do: (in category 'submorphs-accessing') -----
+ morphsAt: aPoint unlocked: aBool do: aBlock
+ "Evaluate aBlock with all the morphs starting at the receiver which appear at aPoint. If aBool is true take only visible, unlocked morphs into account."
+
+ (self fullBounds containsPoint: aPoint) ifFalse:[^self].
+ (aBool and:[self isLocked or:[self visible not]]) ifTrue:[^self].
+ self submorphsDo:[:m| | tfm |
+ tfm := m transformedFrom: self.
+ m morphsAt: (tfm globalPointToLocal: aPoint) unlocked: aBool do: aBlock].
+ (self containsPoint: aPoint) ifTrue:[aBlock value: self].!
Item was added:
+ ----- Method: Morph>>morphsInFrontOf:overlapping:do: (in category 'submorphs-accessing') -----
+ morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock
+ "Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle. someMorph is either an immediate child of the receiver or nil (in which case all submorphs of the receiver are enumerated)."
+ self submorphsDo:[:m|
+ m == someMorph ifTrue:["Try getting out quickly"
+ owner ifNil:[^self].
+ ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock].
+ (m fullBoundsInWorld intersects: aRectangle)
+ ifTrue:[aBlock value: m]].
+ owner ifNil:[^self].
+ ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock.!
Item was added:
+ ----- Method: Morph>>morphsInFrontOverlapping: (in category 'submorphs-accessing') -----
+ morphsInFrontOverlapping: aRectangle
+ "Return all top-level morphs in front of someMorph that overlap with the given rectangle."
+ | morphList |
+ morphList := WriteStream on: Array new.
+ self morphsInFrontOf: nil overlapping: aRectangle do:[:m | morphList nextPut: m].
+ ^morphList contents!
Item was added:
+ ----- Method: Morph>>morphsInFrontOverlapping:do: (in category 'submorphs-accessing') -----
+ morphsInFrontOverlapping: aRectangle do: aBlock
+ "Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle."
+ ^self morphsInFrontOf: nil overlapping: aRectangle do: aBlock!
Item was added:
+ ----- Method: Morph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "Handle a mouse down event. The default response is to let my
+ eventHandler, if any, handle it."
+ evt yellowButtonPressed
+ ifTrue: ["First check for option (menu) click"
+ ^ self yellowButtonActivity: evt shiftPressed].
+ self eventHandler
+ ifNotNil: [self eventHandler mouseDown: evt fromMorph: self]
+ !
Item was added:
+ ----- Method: Morph>>mouseDownOnHelpHandle: (in category 'halos and balloon help') -----
+ mouseDownOnHelpHandle: anEvent
+ "The mouse went down in the show-balloon handle"
+
+ | str |
+ anEvent shiftPressed ifTrue: [^ self editBalloonHelpText].
+ str := self balloonText.
+ str ifNil: [str := self noHelpString].
+ self showBalloon: str hand: anEvent hand.
+ !
Item was added:
+ ----- Method: Morph>>mouseDownPriority (in category 'events-processing') -----
+ mouseDownPriority
+ "Return the default mouse down priority for the receiver"
+
+ ^ (self isPartsDonor or: [self isPartsBin])
+ ifTrue: [50]
+ ifFalse: [0]
+
+ "The above is a workaround for the complete confusion between parts donors and parts bins. Morphs residing in a parts bin may or may not have the parts donor property set; if they have they may or may not actually handle events. To work around this, parts bins get an equal priority to parts donors so that when a morph in the parts bin does have the property set but does not handle the event we still get a copy from picking it up through the parts bin. Argh. This just *cries* for a cleanup."
+ "And the above comment is Andreas's from 10/2000, which was formerly retrievable by a #flag: call which however caused a problem when trying to recompile the method from decompiled source."!
Item was added:
+ ----- Method: Morph>>mouseEnter: (in category 'event handling') -----
+ mouseEnter: evt
+ "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it."
+
+ self eventHandler ifNotNil:
+ [self eventHandler mouseEnter: evt fromMorph: self].
+ !
Item was added:
+ ----- Method: Morph>>mouseEnterDragging: (in category 'event handling') -----
+ mouseEnterDragging: evt
+ "Handle a mouseEnterDragging event, meaning the mouse just entered my bounds with a button pressed or laden with submorphs. The default response is to let my eventHandler, if any, handle it, or else to do nothing."
+
+ self eventHandler ifNotNil:
+ [^ self eventHandler mouseEnterDragging: evt fromMorph: self].
+ !
Item was added:
+ ----- Method: Morph>>mouseLeave: (in category 'event handling') -----
+ mouseLeave: evt
+ "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it."
+
+ self eventHandler ifNotNil:
+ [self eventHandler mouseLeave: evt fromMorph: self].
+ !
Item was added:
+ ----- Method: Morph>>mouseLeaveDragging: (in category 'event handling') -----
+ mouseLeaveDragging: evt
+ "Handle a mouseLeaveLaden event, meaning the mouse just left my bounds with a button pressed or laden with submorphs. The default response is to let my eventHandler, if any, handle it; else to do nothing."
+
+ self eventHandler ifNotNil:
+ [self eventHandler mouseLeaveDragging: evt fromMorph: self]!
Item was added:
+ ----- Method: Morph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ "Handle a mouse move event. The default response is to let my eventHandler, if any, handle it."
+ self eventHandler ifNotNil:
+ [self eventHandler mouseMove: evt fromMorph: self].
+ !
Item was added:
+ ----- Method: Morph>>mouseStillDown: (in category 'event handling') -----
+ mouseStillDown: evt
+ "Handle a mouse move event. The default response is to let my eventHandler, if any, handle it."
+
+ self eventHandler ifNotNil:
+ [self eventHandler mouseStillDown: evt fromMorph: self].
+ !
Item was added:
+ ----- Method: Morph>>mouseStillDownStepRate (in category 'geniestubs') -----
+ mouseStillDownStepRate
+ "At what rate do I want to receive #mouseStillDown: notifications?"
+ ^1!
Item was added:
+ ----- Method: Morph>>mouseStillDownThreshold (in category 'event handling') -----
+ mouseStillDownThreshold
+ "Return the number of milliseconds after which mouseStillDown: should be sent"
+ ^200!
Item was added:
+ ----- Method: Morph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+ "Handle a mouse up event. The default response is to let my eventHandler, if any, handle it."
+
+ self eventHandler ifNotNil:
+ [self eventHandler mouseUp: evt fromMorph: self].
+ !
Item was added:
+ ----- Method: Morph>>mouseUpCodeOrNil (in category 'debug and other') -----
+ mouseUpCodeOrNil
+ "If the receiver has a mouseUpCodeToRun, return it, else return nil"
+
+ ^ self valueOfProperty: #mouseUpCodeToRun ifAbsent: [nil]!
Item was added:
+ ----- Method: Morph>>moveOrResizeFromKeystroke: (in category 'event handling') -----
+ moveOrResizeFromKeystroke: anEvent
+ "move or resize the receiver based on a keystroke"
+ | dir |
+
+ anEvent keyValue = 28 ifTrue: [dir := -1 @ 0].
+ anEvent keyValue = 29 ifTrue: [dir := 1 @ 0].
+ anEvent keyValue = 30 ifTrue: [dir := 0 @ -1].
+ anEvent keyValue = 31 ifTrue: [dir := 0 @ 1].
+
+ dir notNil
+ ifTrue:[
+ anEvent controlKeyPressed ifTrue: [dir := dir * 10].
+
+ anEvent shiftPressed
+ ifTrue: [self extent: self extent + dir]
+ ifFalse: [self position: self position + dir].
+
+ "anEvent wasHandled: true."
+ ]
+ !
Item was added:
+ ----- Method: Morph>>mustBeBackmost (in category 'e-toy support') -----
+ mustBeBackmost
+ "Answer whether the receiver needs to be the backmost morph in its owner's submorph list"
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>name: (in category 'naming') -----
+ name: aName
+ (aName isString) ifTrue: [self setNameTo: aName]!
Item was added:
+ ----- Method: Morph>>nameForFindWindowFeature (in category 'naming') -----
+ nameForFindWindowFeature
+ "Answer the name to show in a list of windows-and-morphs to represent the receiver"
+
+ ^ self knownName ifNil: [self class name]!
Item was added:
+ ----- Method: Morph>>nameForUndoWording (in category 'dropping/grabbing') -----
+ nameForUndoWording
+ "Return wording appropriate to the receiver for use in an undo-related menu item (and perhaps elsewhere)"
+
+ | aName |
+ aName := self knownName ifNil: [self renderedMorph class name].
+ ^ aName truncateTo: 24!
Item was added:
+ ----- Method: Morph>>nameInModel (in category 'naming') -----
+ nameInModel
+ "Return the name for this morph in the underlying model or nil."
+
+ | w |
+ w := self world.
+ w isNil ifTrue: [^nil] ifFalse: [^w model nameFor: self]!
Item was added:
+ ----- Method: Morph>>nameOfObjectRepresented (in category 'naming') -----
+ nameOfObjectRepresented
+ "Answer the external name of the object represented"
+
+ ^ self externalName!
Item was added:
+ ----- Method: Morph>>nearestOwnerThat: (in category 'structure') -----
+ nearestOwnerThat: conditionBlock
+ "Return the first enclosing morph for which aBlock evaluates to true, or nil if none"
+
+ ^ self firstOwnerSuchThat: conditionBlock
+ !
Item was added:
+ ----- Method: Morph>>newTransformationMorph (in category 'rotate scale and flex') -----
+ newTransformationMorph
+ ^TransformationMorph new!
Item was added:
+ ----- Method: Morph>>nextOwnerPage (in category 'geometry') -----
+ nextOwnerPage
+ "Tell my container to advance to the next page"
+ | targ |
+ targ := self ownerThatIsA: BookMorph.
+ targ ifNotNil: [targ nextPage]!
Item was added:
+ ----- Method: Morph>>noHelpString (in category 'halos and balloon help') -----
+ noHelpString
+ ^ 'Help not yet supplied' translated!
Item was added:
+ ----- Method: Morph>>noteDecimalPlaces:forGetter: (in category 'e-toy support') -----
+ noteDecimalPlaces: aNumber forGetter: aGetter
+ "Make a mental note of the user's preference for a particular number of decimal places to be associated with the slot with the given getter"
+
+ (self renderedMorph valueOfProperty: #decimalPlacePreferences ifAbsentPut: [IdentityDictionary new])
+ at: aGetter put: aNumber!
Item was added:
+ ----- Method: Morph>>noteNewOwner: (in category 'submorphs-accessing') -----
+ noteNewOwner: aMorph
+ "I have just been added as a submorph of aMorph"!
Item was added:
+ ----- Method: Morph>>objectForDataStream: (in category 'objects from disk') -----
+ objectForDataStream: refStrm
+ "I am being written out on an object file"
+
+ | dp |
+ self sqkPage ifNotNil:
+ [refStrm rootObject == self | (refStrm rootObject == self sqkPage)
+ ifFalse:
+ [self url notEmpty
+ ifTrue:
+ [dp := self sqkPage copyForSaving. "be careful touching this object!!"
+ refStrm replace: self with: dp.
+ ^dp]]].
+ self prepareToBeSaved. "Amen"
+ ^self!
Item was added:
+ ----- Method: Morph>>objectViewed (in category 'e-toy support') -----
+ objectViewed
+ "Answer the morph associated with the player that the structure the receiver currently finds itself within represents."
+
+ ^ (self outermostMorphThat: [:o | o isViewer or:[ o isScriptEditorMorph]]) objectViewed
+ !
Item was added:
+ ----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') -----
+ obtrudesBeyondContainer
+ "Answer whether the receiver obtrudes beyond the bounds of its container"
+
+ | top |
+ top := self topRendererOrSelf.
+ (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
+ ^(top owner bounds containsRect: top bounds) not!
Item was added:
+ ----- Method: Morph>>offerCostumeViewerMenu: (in category 'menu') -----
+ offerCostumeViewerMenu: aMenu
+ "do nothing"!
Item was added:
+ ----- Method: Morph>>okayToAddDismissHandle (in category 'halos and balloon help') -----
+ okayToAddDismissHandle
+ "Answer whether a halo on the receiver should offer a dismiss handle. This provides a hook for making it harder to disassemble some strucures even momentarily"
+
+ ^ self resistsRemoval not!
Item was added:
+ ----- Method: Morph>>okayToAddGrabHandle (in category 'halos and balloon help') -----
+ okayToAddGrabHandle
+ "Answer whether a halo on the receiver should offer a grab handle. This provides a hook for making it harder to deconstruct some strucures even momentarily"
+
+ ^ true!
Item was added:
+ ----- Method: Morph>>okayToBrownDragEasily (in category 'halos and balloon help') -----
+ okayToBrownDragEasily
+ "Answer whether it it okay for the receiver to be brown-dragged easily -- i.e. repositioned within its container without extracting it. At present this is just a hook -- nobody declines."
+
+ ^ true
+
+
+
+ "
+ ^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and:
+ [self layoutPolicy isNil]"!
Item was added:
+ ----- Method: Morph>>okayToDuplicate (in category 'player') -----
+ okayToDuplicate
+ "Formerly this protocol was used to guard against awkward situations when there were anonymous scripts in the etoy system. Nowadays we just always allow duplication"
+
+ ^ true!
Item was added:
+ ----- Method: Morph>>okayToExtractEasily (in category 'halos and balloon help') -----
+ okayToExtractEasily
+ "Answer whether it it okay for the receiver to be extracted easily. Not yet hooked up to the halo-permissions mechanism."
+
+ ^ self topRendererOrSelf owner dragNDropEnabled!
Item was added:
+ ----- Method: Morph>>okayToResizeEasily (in category 'halos and balloon help') -----
+ okayToResizeEasily
+ "Answer whether it is appropriate to have the receiver be easily resized by the user from the halo"
+
+ ^ true
+
+ "This one was too jarring, not that it didn't most of the time do the right thing but because some of the time it didn't, such as in a holder. If we pursue this path, the test needs to be airtight, obviously...
+ ^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and:
+ [self layoutPolicy isNil]"!
Item was added:
+ ----- Method: Morph>>okayToRotateEasily (in category 'halos and balloon help') -----
+ okayToRotateEasily
+ "Answer whether it is appropriate for a rotation handle to be shown for the receiver. This is a hook -- at present nobody declines."
+
+ ^ true!
Item was added:
+ ----- Method: Morph>>on:send:to: (in category 'event handling') -----
+ on: eventName send: selector to: recipient
+ self eventHandler ifNil: [self eventHandler: EventHandler new].
+ self eventHandler on: eventName send: selector to: recipient!
Item was added:
+ ----- Method: Morph>>on:send:to:withValue: (in category 'event handling') -----
+ on: eventName send: selector to: recipient withValue: value
+ "NOTE: selector must take 3 arguments, of which value will be the *** FIRST ***"
+
+ self eventHandler ifNil: [self eventHandler: EventHandler new].
+ self eventHandler on: eventName send: selector to: recipient withValue: value
+ !
Item was added:
+ ----- Method: Morph>>openAPropertySheet (in category 'meta-actions') -----
+ openAPropertySheet
+
+ Smalltalk at: #ObjectPropertiesMorph ifPresent:[:aClass|
+ ^aClass basicNew
+ targetMorph: self;
+ initialize;
+ openNearTarget
+ ].
+ Beeper beep.!
Item was added:
+ ----- Method: Morph>>openATextPropertySheet (in category 'meta-actions') -----
+ openATextPropertySheet
+
+ "should only be sent to morphs that are actually supportive"
+
+ Smalltalk at: #TextPropertiesMorph ifPresent:[:aClass|
+ ^aClass basicNew
+ targetMorph: self;
+ initialize;
+ openNearTarget
+ ].
+ Beeper beep.!
Item was added:
+ ----- Method: Morph>>openCenteredInWorld (in category 'initialization') -----
+ openCenteredInWorld
+
+ self
+ fullBounds;
+ position: Display extent - self extent // 2;
+ openInWorld.!
Item was added:
+ ----- Method: Morph>>openInHand (in category 'initialization') -----
+ openInHand
+ "Attach the receiver to the current hand in the current morphic world"
+
+ self currentHand attachMorph: self!
Item was added:
+ ----- Method: Morph>>openInWindow (in category 'initialization') -----
+ openInWindow
+
+ ^self openInWindowLabeled: self defaultLabelForInspector
+ !
Item was added:
+ ----- Method: Morph>>openInWindowLabeled: (in category 'initialization') -----
+ openInWindowLabeled: aString
+
+ ^self openInWindowLabeled: aString inWorld: self currentWorld!
Item was added:
+ ----- Method: Morph>>openInWindowLabeled:inWorld: (in category 'initialization') -----
+ openInWindowLabeled: aString inWorld: aWorld
+
+ | window extent |
+
+ window := (SystemWindow labelled: aString) model: nil.
+ window
+ " guess at initial extent"
+ bounds: (RealEstateAgent initialFrameFor: window initialExtent: self fullBounds extent world: aWorld);
+ addMorph: self frame: (0 at 0 extent: 1 at 1);
+ updatePaneColors.
+ " calculate extent after adding in case any size related attributes were changed. Use
+ fullBounds in order to trigger re-layout of layout morphs"
+ extent := self fullBounds extent +
+ (window borderWidth at window labelHeight) + window borderWidth.
+ window extent: extent.
+ aWorld addMorph: window.
+ window activate.
+ aWorld startSteppingSubmorphsOf: window.
+ ^window
+ !
Item was added:
+ ----- Method: Morph>>openInWorld (in category 'initialization') -----
+ openInWorld
+ "Add this morph to the world."
+
+ self openInWorld: self currentWorld.!
Item was added:
+ ----- Method: Morph>>openInWorld: (in category 'initialization') -----
+ openInWorld: aWorld
+ "Add this morph to the requested World."
+ (aWorld visibleClearArea origin ~= (0 at 0) and: [self position = (0 at 0)]) ifTrue:
+ [self position: aWorld visibleClearArea origin].
+ aWorld addMorph: self.
+ aWorld startSteppingSubmorphsOf: self!
Item was added:
+ ----- Method: Morph>>openModal: (in category 'polymorph') -----
+ openModal: aSystemWindow
+ "Open the given window locking the receiver until it is dismissed.
+ Answer the system window.
+ Restore the original keyboard focus when closed."
+
+ |area mySysWin keyboardFocus|
+ keyboardFocus := self activeHand keyboardFocus.
+ mySysWin := self isSystemWindow ifTrue: [self] ifFalse: [self ownerThatIsA: SystemWindow].
+ mySysWin ifNil: [mySysWin := self].
+ mySysWin modalLockTo: aSystemWindow.
+ area := RealEstateAgent maximumUsableArea.
+ aSystemWindow extent: aSystemWindow initialExtent.
+ aSystemWindow position = (0 at 0)
+ ifTrue: [aSystemWindow
+ position: self activeHand position - (aSystemWindow extent // 2)].
+ aSystemWindow
+ bounds: (aSystemWindow bounds translatedToBeWithin: area).
+ [ToolBuilder default runModal: aSystemWindow openAsIs]
+ ensure: [mySysWin modalUnlockFrom: aSystemWindow.
+ self activeHand newKeyboardFocus: keyboardFocus].
+ ^aSystemWindow!
Item was added:
+ ----- Method: Morph>>openNear: (in category 'initialization') -----
+ openNear: aRectangle
+ self
+ openNear: aRectangle
+ in: World!
Item was added:
+ ----- Method: Morph>>openNear:in: (in category 'initialization') -----
+ openNear: aRectangle in: aWorld
+ | wb leftOverlap rightOverlap topOverlap bottomOverlap best |
+ wb := aWorld bounds.
+ self fullBounds.
+ leftOverlap := self width - (aRectangle left - wb left).
+ rightOverlap := self width - (wb right - aRectangle right).
+ topOverlap := self height - (aRectangle top - wb top).
+ bottomOverlap := self height - (wb bottom - aRectangle bottom).
+ best := nil.
+ {
+ {leftOverlap. #topRight:. #topLeft}.
+ {rightOverlap. #topLeft:. #topRight}.
+ {topOverlap. #bottomLeft:. #topLeft}.
+ {bottomOverlap. #topLeft:. #bottomLeft}.
+ } do: [ :tuple |
+ (best isNil or: [tuple first < best first]) ifTrue: [best := tuple].
+ ].
+ self perform: best second with: (aRectangle perform: best third).
+ self bottom: (self bottom min: wb bottom) rounded.
+ self right: (self right min: wb right) rounded.
+ self top: (self top max: wb top) rounded.
+ self left: (self left max: wb left) rounded.
+ self openInWorld: aWorld.!
Item was added:
+ ----- Method: Morph>>openNearMorph: (in category 'initialization') -----
+ openNearMorph: aMorph
+ self
+ openNear: aMorph boundsInWorld
+ in: (aMorph world ifNil: [ World ])!
Item was added:
+ ----- Method: Morph>>openViewerForArgument (in category 'player viewer') -----
+ openViewerForArgument
+ "Open up a viewer for a player associated with the morph in question. "
+ self presenter viewMorph: self!
Item was added:
+ ----- Method: Morph>>orOwnerSuchThat: (in category 'structure') -----
+ orOwnerSuchThat: conditionBlock
+
+ (conditionBlock value: self) ifTrue: [^ self].
+ self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]].
+ ^ nil
+
+ !
Item was added:
+ ----- Method: Morph>>otherProperties (in category 'accessing - properties') -----
+ otherProperties
+ "answer the receiver's otherProperties"
+ ^ extension ifNotNil: [extension otherProperties]!
Item was added:
+ ----- Method: Morph>>outOfWorld: (in category 'initialization') -----
+ outOfWorld: aWorld
+ "The receiver has just appeared in a new world. Notes:
+ * aWorld can be nil (due to optimizations in other places)
+ * owner is still valid
+ Important: Keep this method fast - it is run whenever morphs are removed."
+ aWorld ifNil:[^self].
+ "ar 1/31/2001: We could explicitly stop stepping the receiver here but for the sake of speed I'm for now relying on the lazy machinery in the world itself."
+ "aWorld stopStepping: self."
+ self submorphsDo:[:m| m outOfWorld: aWorld].
+ !
Item was added:
+ ----- Method: Morph>>outerBounds (in category 'geometry') -----
+ outerBounds
+ "Return the 'outer' bounds of the receiver, e.g., the bounds that need to be invalidated when the receiver changes."
+ | box |
+ box := self bounds.
+ self hasDropShadow ifTrue:[box := self expandFullBoundsForDropShadow: box].
+ self hasRolloverBorder ifTrue:[box := self expandFullBoundsForRolloverBorder: box].
+ ^box!
Item was added:
+ ----- Method: Morph>>outermostMorphThat: (in category 'structure') -----
+ outermostMorphThat: conditionBlock
+ "Return the outermost containing morph for which aBlock is true, or nil if none"
+
+ | outermost |
+ self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [outermost := m]].
+ ^ outermost!
Item was added:
+ ----- Method: Morph>>outermostOwnerWithYellowButtonMenu (in category 'menu') -----
+ outermostOwnerWithYellowButtonMenu
+ "Answer me or my outermost owner that is willing to contribute menu items to a context menu.
+ Don't include the world."
+
+ | outermost |
+ outermost := self outermostMorphThat: [ :ea |
+ ea isWorldMorph not and: [ ea hasYellowButtonMenu ]].
+ ^outermost ifNil: [ self hasYellowButtonMenu ifTrue: [ self ] ifFalse: []] !
Item was added:
+ ----- Method: Morph>>outermostWorldMorph (in category 'structure') -----
+ outermostWorldMorph
+
+ | outer |
+ World ifNotNil:[^World].
+ self flag: #arNote. "stuff below is really only for MVC"
+ outer := self outermostMorphThat: [ :x | x isWorldMorph].
+ outer ifNotNil: [^outer].
+ self isWorldMorph ifTrue: [^self].
+ ^nil!
Item was added:
+ ----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') -----
+ overlapsShadowForm: itsShadow bounds: itsBounds
+ "Answer true if itsShadow and my shadow overlap at all"
+ | andForm overlapExtent |
+ overlapExtent := (itsBounds intersect: self fullBounds) extent.
+ overlapExtent > (0 @ 0)
+ ifFalse: [^ false].
+ andForm := self shadowForm.
+ overlapExtent ~= self fullBounds extent
+ ifTrue: [andForm := andForm
+ contentsOfArea: (0 @ 0 extent: overlapExtent)].
+ andForm := andForm
+ copyBits: (self fullBounds translateBy: itsShadow offset negated)
+ from: itsShadow
+ at: 0 @ 0
+ clippingBox: (0 @ 0 extent: overlapExtent)
+ rule: Form and
+ fillColor: nil.
+ ^ andForm bits
+ anySatisfy: [:w | w ~= 0]!
Item was added:
+ ----- Method: Morph>>owner (in category 'structure') -----
+ owner
+ "Returns the owner of this morph, which may be nil."
+
+ ^ owner!
Item was added:
+ ----- Method: Morph>>ownerChain (in category 'debug and other') -----
+ ownerChain
+ "Answer a list of objects representing the receiver and all of its owners. The first element is the receiver, and the last one is typically the world in which the receiver resides"
+
+ | c next |
+ c := OrderedCollection with: self.
+ next := self.
+ [(next := next owner) notNil] whileTrue: [c add: next].
+ ^c asArray!
Item was added:
+ ----- Method: Morph>>ownerChanged (in category 'change reporting') -----
+ ownerChanged
+ "The receiver's owner, some kind of a pasteup, has changed its layout."
+
+ self snapToEdgeIfAppropriate!
Item was added:
+ ----- Method: Morph>>ownerThatIsA: (in category 'structure') -----
+ ownerThatIsA: aClass
+ "Return the first enclosing morph that is a kind of aClass, or nil if none"
+
+ ^ self firstOwnerSuchThat: [:m | m isKindOf: aClass]!
Item was added:
+ ----- Method: Morph>>ownerThatIsA:orA: (in category 'structure') -----
+ ownerThatIsA: firstClass orA: secondClass
+ "Return the first enclosing morph that is a kind of one of the two classes given, or nil if none"
+
+ ^ self firstOwnerSuchThat: [:m | (m isKindOf: firstClass) or: [m isKindOf: secondClass]]!
Item was added:
+ ----- Method: Morph>>pagesHandledAutomatically (in category 'printing') -----
+ pagesHandledAutomatically
+
+ ^false!
Item was added:
+ ----- Method: Morph>>partRepresented (in category 'parts bin') -----
+ partRepresented
+ ^self!
Item was added:
+ ----- Method: Morph>>pasteUpMorph (in category 'structure') -----
+ pasteUpMorph
+ "Answer the closest containing morph that is a PasteUp morph"
+ ^ self ownerThatIsA: PasteUpMorph!
Item was added:
+ ----- Method: Morph>>pasteUpMorphHandlingTabAmongFields (in category 'structure') -----
+ pasteUpMorphHandlingTabAmongFields
+ "Answer the nearest PasteUpMorph in my owner chain that has the tabAmongFields property, or nil if none"
+
+ | aPasteUp |
+ aPasteUp := self owner.
+ [aPasteUp notNil] whileTrue:
+ [aPasteUp tabAmongFields ifTrue:
+ [^ aPasteUp].
+ aPasteUp := aPasteUp owner].
+ ^ nil!
Item was added:
+ ----- Method: Morph>>pauseFrom: (in category '*Morphic-Sound-piano rolls') -----
+ pauseFrom: scorePlayer
+
+ "subclasses should take five"!
Item was added:
+ ----- Method: Morph>>permitsThumbnailing (in category 'thumbnail') -----
+ permitsThumbnailing
+ ^ true!
Item was added:
+ ----- Method: Morph>>playSoundNamed: (in category 'player commands') -----
+ playSoundNamed: soundName
+ "Play the sound with the given name.
+ Does nothing if this image lacks sound playing facilities."
+
+ SoundService default playSoundNamed: soundName asString!
Item was added:
+ ----- Method: Morph>>player (in category 'accessing') -----
+ player
+ "answer the receiver's player"
+ ^ extension ifNotNil: [extension player]!
Item was added:
+ ----- Method: Morph>>player: (in category 'accessing') -----
+ player: anObject
+ "change the receiver's player"
+ self assureExtension player: anObject!
Item was added:
+ ----- Method: Morph>>playerRepresented (in category 'accessing') -----
+ playerRepresented
+ "Answer the player represented by the receiver. Morphs that serve as references to other morphs reimplement this; be default a morph represents its own player."
+
+ ^ self player!
Item was added:
+ ----- Method: Morph>>point:from: (in category 'geometry') -----
+ point: aPoint from: aReferenceMorph
+
+ owner ifNil: [^ aPoint].
+ ^ (owner transformFrom: aReferenceMorph) globalPointToLocal: aPoint.
+ !
Item was added:
+ ----- Method: Morph>>point:in: (in category 'geometry') -----
+ point: aPoint in: aReferenceMorph
+
+ owner ifNil: [^ aPoint].
+ ^ (owner transformFrom: aReferenceMorph) localPointToGlobal: aPoint.
+ !
Item was added:
+ ----- Method: Morph>>pointFromWorld: (in category 'geometry') -----
+ pointFromWorld: aPoint
+ ^self point: aPoint from: self world!
Item was added:
+ ----- Method: Morph>>pointInWorld: (in category 'geometry') -----
+ pointInWorld: aPoint
+ ^self point: aPoint in: self world!
Item was added:
+ ----- Method: Morph>>position (in category 'geometry') -----
+ position
+
+ ^ bounds topLeft!
Item was added:
+ ----- Method: Morph>>position: (in category 'geometry') -----
+ position: aPoint
+ "Change the position of this morph and and all of its
+ submorphs. "
+ | delta box |
+ delta := (aPoint - bounds topLeft) rounded.
+ (delta x = 0
+ and: [delta y = 0])
+ ifTrue: [^ self].
+ "Null change"
+ box := self fullBounds.
+ (delta dotProduct: delta)
+ > 100
+ ifTrue: ["e.g., more than 10 pixels moved"
+ self invalidRect: box.
+ self
+ invalidRect: (box translateBy: delta)]
+ ifFalse: [self
+ invalidRect: (box
+ merge: (box translateBy: delta))].
+ self privateFullMoveBy: delta.
+ owner
+ ifNotNil: [owner layoutChanged]!
Item was added:
+ ----- Method: Morph>>positionInWorld (in category 'geometry') -----
+ positionInWorld
+
+ ^ self pointInWorld: self position.
+ !
Item was added:
+ ----- Method: Morph>>positionSubmorphs (in category 'geometry') -----
+ positionSubmorphs
+ self submorphsDo:
+ [:aMorph | aMorph snapToEdgeIfAppropriate]!
Item was added:
+ ----- Method: Morph>>potentialEmbeddingTargets (in category 'meta-actions') -----
+ potentialEmbeddingTargets
+ "Return the potential targets for embedding the receiver"
+
+ | oneUp topRend |
+ (oneUp := (topRend := self topRendererOrSelf) owner) ifNil:[^#()].
+ ^ (oneUp morphsAt: topRend referencePosition behind: topRend unlocked: true) select:
+ [:m | m isFlexMorph not]!
Item was added:
+ ----- Method: Morph>>potentialTargets (in category 'meta-actions') -----
+ potentialTargets
+ "Return the potential targets for the receiver.
+ This is derived from Morph>>potentialEmbeddingTargets."
+ owner ifNil:[^#()].
+ ^owner morphsAt: self referencePosition behind: self unlocked: true not!
Item was added:
+ ----- Method: Morph>>potentialTargetsAt: (in category 'meta-actions') -----
+ potentialTargetsAt: aPoint
+ "Return the potential targets for the receiver.
+ This is derived from Morph>>potentialEmbeddingTargets."
+ | realOwner |
+ realOwner := self topRendererOrSelf
+ owner
+ ifNil: [^ #()].
+ ^ realOwner
+ morphsAt: aPoint
+ !
Item was added:
+ ----- Method: Morph>>preferredDuplicationHandleSelector (in category 'halos and balloon help') -----
+ preferredDuplicationHandleSelector
+ "Answer the selector, either #addMakeSiblingHandle: or addDupHandle:, to be offered as the default in a halo open on me"
+
+ Preferences oliveHandleForScriptedObjects ifFalse:
+ [^ #addDupHandle:].
+ ^ self renderedMorph valueOfProperty: #preferredDuplicationHandleSelector ifAbsent:
+ [self player class isUniClass
+ ifTrue:
+ [#addMakeSiblingHandle:]
+ ifFalse:
+ [#addDupHandle:]]!
Item was added:
+ ----- Method: Morph>>preferredKeyboardBounds (in category 'event handling') -----
+ preferredKeyboardBounds
+
+ ^ self bounds: self bounds in: World.
+ !
Item was added:
+ ----- Method: Morph>>preferredKeyboardPosition (in category 'event handling') -----
+ preferredKeyboardPosition
+
+ ^ (self bounds: self bounds in: World) topLeft.
+ !
Item was added:
+ ----- Method: Morph>>prepareToBeSaved (in category 'fileIn/out') -----
+ prepareToBeSaved
+ "Prepare this morph to be saved to disk. Subclasses should nil out any instance variables that holds state that should not be saved, such as cached Forms. Note that this operation may take more drastic measures than releaseCachedState; for example, it might discard the transcript of an interactive chat session."
+
+ self releaseCachedState.
+ self formerOwner: nil.
+ self formerPosition: nil.
+ self removeProperty: #undoGrabCommand.
+ fullBounds := nil!
Item was added:
+ ----- Method: Morph>>presentHelp (in category 'menus') -----
+ presentHelp
+ "Present a help message if there is one available"
+
+ self inform: 'Sorry, no help has been
+ provided here yet.'!
Item was added:
+ ----- Method: Morph>>presenter (in category 'accessing') -----
+ presenter
+ ^ owner ifNotNil: [owner presenter] ifNil: [self currentWorld presenter]!
Item was added:
+ ----- Method: Morph>>previousOwnerPage (in category 'geometry') -----
+ previousOwnerPage
+ "Tell my container to advance to the previous page"
+ | targ |
+ targ := self ownerThatIsA: BookMorph.
+ targ ifNotNil: [targ previousPage]!
Item was added:
+ ----- Method: Morph>>primaryHand (in category 'structure') -----
+ primaryHand
+
+ | outer |
+ outer := self outermostWorldMorph ifNil: [^ nil].
+ ^ outer activeHand ifNil: [outer firstHand]!
Item was added:
+ ----- Method: Morph>>printConstructorOn:indent: (in category 'printing') -----
+ printConstructorOn: aStream indent: level
+
+ ^ self printConstructorOn: aStream indent: level nodeDict: IdentityDictionary new
+ !
Item was added:
+ ----- Method: Morph>>printConstructorOn:indent:nodeDict: (in category 'printing') -----
+ printConstructorOn: aStream indent: level nodeDict: nodeDict
+ | nodeString |
+ (nodeString := nodeDict at: self ifAbsent: [nil])
+ ifNotNil: [^ aStream nextPutAll: nodeString].
+ submorphs isEmpty ifFalse: [aStream nextPutAll: '('].
+ aStream nextPutAll: '('.
+ self fullPrintOn: aStream.
+ aStream nextPutAll: ')'.
+ submorphs isEmpty ifTrue: [^ self].
+ submorphs size <= 4
+ ifTrue:
+ [aStream crtab: level+1;
+ nextPutAll: 'addAllMorphs: (Array'.
+ 1 to: submorphs size do:
+ [:i | aStream crtab: level+1; nextPutAll: 'with: '.
+ (submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict].
+ aStream nextPutAll: '))']
+ ifFalse:
+ [aStream crtab: level+1;
+ nextPutAll: 'addAllMorphs: ((Array new: ', submorphs size printString, ')'.
+ 1 to: submorphs size do:
+ [:i |
+ aStream crtab: level+1; nextPutAll: 'at: ', i printString, ' put: '.
+ (submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict.
+ aStream nextPutAll: ';'].
+ aStream crtab: level+1; nextPutAll: 'yourself))']!
Item was added:
+ ----- Method: Morph>>printOn: (in category 'printing') -----
+ printOn: aStream
+ | aName |
+ super printOn: aStream.
+ (aName := self knownName) notNil
+ ifTrue: [aStream nextPutAll: '<' , aName , '>'].
+ aStream nextPutAll: '('.
+ aStream
+ print: self identityHash;
+ nextPutAll: ')'!
Item was added:
+ ----- Method: Morph>>printPSToFile (in category '*morphic-Postscript Canvases') -----
+ printPSToFile
+
+ self printPSToFileNamed: self externalName!
Item was added:
+ ----- Method: Morph>>printSpecs (in category 'printing') -----
+ printSpecs
+
+ | printSpecs |
+
+ printSpecs := self valueOfProperty: #PrintSpecifications.
+ printSpecs ifNil: [
+ printSpecs := PrintSpecifications defaultSpecs.
+ self printSpecs: printSpecs.
+ ].
+ ^printSpecs!
Item was added:
+ ----- Method: Morph>>printSpecs: (in category 'printing') -----
+ printSpecs: aPrintSecification
+
+ self setProperty: #PrintSpecifications toValue: aPrintSecification.
+ !
Item was added:
+ ----- Method: Morph>>printStructureOn:indent: (in category 'printing') -----
+ printStructureOn: aStream indent: tabCount
+
+ tabCount timesRepeat: [aStream tab].
+ self printOn: aStream.
+ aStream cr.
+ self submorphsDo: [:m | m printStructureOn: aStream indent: tabCount + 1].
+ !
Item was added:
+ ----- Method: Morph>>privateAddAllMorphs:atIndex: (in category 'private') -----
+ privateAddAllMorphs: aCollection atIndex: index
+ "Private. Add aCollection of morphs to the receiver"
+ | myWorld otherSubmorphs offset |
+ (index between: 1 and: submorphs size+1)
+ ifFalse: [^ self error: 'index out of range'].
+ myWorld := self world.
+ otherSubmorphs := submorphs copyWithoutAll: aCollection.
+ offset := aCollection count: [:m | (submorphs indexOf: m) between: 1 and: index - 1].
+ submorphs := otherSubmorphs copyReplaceFrom: index-offset to: index-offset-1 with: aCollection.
+ aCollection do: [:m | | itsOwner itsWorld |
+ itsOwner := m owner.
+ itsOwner ifNotNil: [
+ itsWorld := m world.
+ (itsWorld == myWorld) ifFalse: [
+ itsWorld ifNotNil: [self privateInvalidateMorph: m].
+ m outOfWorld: itsWorld].
+ (itsOwner ~~ self) ifTrue: [
+ m owner privateRemove: m.
+ m owner removedMorph: m ]].
+ m privateOwner: self.
+ myWorld ifNotNil: [self privateInvalidateMorph: m].
+ (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld].
+ itsOwner == self ifFalse: [
+ self addedMorph: m.
+ m noteNewOwner: self ].
+ ].
+ self layoutChanged.
+ !
Item was added:
+ ----- Method: Morph>>privateAddMorph:atIndex: (in category 'private') -----
+ privateAddMorph: aMorph atIndex: index
+
+ | oldIndex myWorld itsWorld oldOwner |
+ ((index >= 1) and: [index <= (submorphs size + 1)])
+ ifFalse: [^ self error: 'index out of range'].
+ myWorld := self world.
+ oldOwner := aMorph owner.
+ (oldOwner == self and: [(oldIndex := submorphs indexOf: aMorph) > 0]) ifTrue:[
+ "aMorph's position changes within in the submorph chain"
+ oldIndex < index ifTrue:[
+ "moving aMorph to back"
+ submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1.
+ submorphs at: index-1 put: aMorph.
+ ] ifFalse:[
+ "moving aMorph to front"
+ oldIndex-1 to: index by: -1 do:[:i|
+ submorphs at: i+1 put: (submorphs at: i)].
+ submorphs at: index put: aMorph.
+ ].
+ ] ifFalse:[
+ "adding a new morph"
+ oldOwner ifNotNil:[
+ itsWorld := aMorph world.
+ itsWorld ifNotNil: [self privateInvalidateMorph: aMorph].
+ (itsWorld == myWorld) ifFalse: [aMorph outOfWorld: itsWorld].
+ oldOwner privateRemove: aMorph.
+ oldOwner removedMorph: aMorph.
+ ].
+ aMorph privateOwner: self.
+ submorphs := submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph).
+ (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld].
+ ].
+ myWorld ifNotNil:[self privateInvalidateMorph: aMorph].
+ self layoutChanged.
+ oldOwner == self ifFalse: [
+ self addedMorph: aMorph.
+ aMorph noteNewOwner: self ].
+ !
Item was added:
+ ----- Method: Morph>>privateBounds: (in category 'private') -----
+ privateBounds: boundsRect
+ "Private!! Use position: and/or extent: instead."
+
+ fullBounds := nil.
+ bounds := boundsRect.!
Item was added:
+ ----- Method: Morph>>privateColor: (in category 'private') -----
+ privateColor: aColor
+
+ color := aColor.
+ !
Item was added:
+ ----- Method: Morph>>privateDelete (in category 'submorphs-add/remove') -----
+ privateDelete
+ "Remove the receiver as a submorph of its owner"
+ owner ifNotNil:[owner removeMorph: self].!
Item was added:
+ ----- Method: Morph>>privateDeleteWithAbsolutelyNoSideEffects (in category 'private') -----
+ privateDeleteWithAbsolutelyNoSideEffects
+ "Private!! Should only be used by methods that maintain the ower/submorph invariant."
+ "used to delete a morph from an inactive world"
+
+ owner ifNil: [^self].
+ owner privateRemoveMorphWithAbsolutelyNoSideEffects: self.
+ owner := nil.
+
+ !
Item was added:
+ ----- Method: Morph>>privateExtension: (in category 'accessing - extension') -----
+ privateExtension: aMorphExtension
+ "private - change the receiver's extension"
+ extension := aMorphExtension!
Item was added:
+ ----- Method: Morph>>privateFullBounds (in category 'layout') -----
+ privateFullBounds
+ "Private. Compute the actual full bounds of the receiver"
+
+ | box |
+ submorphs isEmpty ifTrue: [^self outerBounds].
+ box := self outerBounds copy.
+ box := box quickMerge: (self clipSubmorphs
+ ifTrue: [self submorphBounds intersect: self clippingBounds]
+ ifFalse: [self submorphBounds]).
+ ^box origin asIntegerPoint corner: box corner asIntegerPoint!
Item was added:
+ ----- Method: Morph>>privateFullBounds: (in category 'private') -----
+ privateFullBounds: boundsRect
+ "Private!! Computed automatically."
+
+ fullBounds := boundsRect.!
Item was added:
+ ----- Method: Morph>>privateFullMoveBy: (in category 'private') -----
+ privateFullMoveBy: delta
+ "Private!! Relocate me and all of my subMorphs by recursion. Subclasses that implement different coordinate systems may override this method."
+
+ self privateMoveBy: delta.
+ 1 to: submorphs size do: [:i |
+ (submorphs at: i) privateFullMoveBy: delta].
+ owner ifNotNil:[
+ owner isTextMorph ifTrue:[owner adjustTextAnchor: self]].!
Item was added:
+ ----- Method: Morph>>privateInvalidateMorph: (in category 'change reporting') -----
+ privateInvalidateMorph: aMorph
+ "Private. Invalidate the given morph after adding or removing.
+ This method is private because a) we're invalidating the morph 'remotely'
+ and b) it forces a fullBounds computation which should not be necessary
+ for a general morph c) the morph may or may not actually invalidate
+ anything (if it's not in the world nothing will happen) and d) the entire
+ mechanism should be rewritten."
+ aMorph fullBounds.
+ aMorph changed!
Item was added:
+ ----- Method: Morph>>privateMoveBy: (in category 'private') -----
+ privateMoveBy: delta
+ "Private!! Use 'position:' instead."
+ | fill |
+ self player ifNotNil: ["Most cases eliminated fast by above test"
+ self getPenDown ifTrue: [
+ "If this is a costume for a player with its
+ pen down, draw a line."
+ self moveWithPenDownBy: delta]].
+ bounds := bounds translateBy: delta.
+ fullBounds ifNotNil: [fullBounds := fullBounds translateBy: delta].
+ fill := self fillStyle.
+ fill isOrientedFill ifTrue: [fill origin: fill origin + delta]!
Item was added:
+ ----- Method: Morph>>privateOwner: (in category 'private') -----
+ privateOwner: aMorph
+ "Private!! Should only be used by methods that maintain the ower/submorph invariant."
+
+ owner := aMorph.!
Item was added:
+ ----- Method: Morph>>privateRemove: (in category 'private') -----
+ privateRemove: aMorph
+ "Private!! Should only be used by methods that maintain the ower/submorph invariant."
+
+ submorphs := submorphs copyWithout: aMorph.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>privateRemoveMorphWithAbsolutelyNoSideEffects: (in category 'private') -----
+ privateRemoveMorphWithAbsolutelyNoSideEffects: aMorph
+ "Private!! Should only be used by methods that maintain the ower/submorph invariant."
+ "used to delete a morph from an inactive world"
+
+ submorphs := submorphs copyWithout: aMorph.
+
+ !
Item was added:
+ ----- Method: Morph>>privateSubmorphs (in category 'private') -----
+ privateSubmorphs
+ "Private!! Use 'submorphs' instead."
+
+ ^ submorphs!
Item was added:
+ ----- Method: Morph>>privateSubmorphs: (in category 'private') -----
+ privateSubmorphs: aCollection
+ "Private!! Should only be used by methods that maintain the ower/submorph invariant."
+
+ submorphs := aCollection.!
Item was added:
+ ----- Method: Morph>>processEvent: (in category 'events-processing') -----
+ processEvent: anEvent
+ "Process the given event using the default event dispatcher."
+ ^self processEvent: anEvent using: self defaultEventDispatcher!
Item was added:
+ ----- Method: Morph>>processEvent:using: (in category 'events-processing') -----
+ processEvent: anEvent using: defaultDispatcher
+ "This is the central entry for dispatching events in morphic. Given some event and a default dispatch strategy, find the right receiver and let him handle it.
+ WARNING: This is a powerful hook. If you want to use a different event dispatcher from the default, here is the place to hook it in. Depending on how the dispatcher is written (e.g., whether it calls simply #processEvent: or #processEvent:using:) you can change the dispatch strategy for entire trees of morphs. Similarly, you can disable entire trees of morphs from receiving any events whatsoever. Read the documentation in class MorphicEventDispatcher before playing with it. "
+ (self rejectsEvent: anEvent) ifTrue:[^#rejected].
+ ^defaultDispatcher dispatchEvent: anEvent with: self!
Item was added:
+ ----- Method: Morph>>programmedMouseDown:for: (in category 'debug and other') -----
+ programmedMouseDown: anEvent for: aMorph
+
+ aMorph addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7).
+
+ !
Item was added:
+ ----- Method: Morph>>programmedMouseEnter:for: (in category 'debug and other') -----
+ programmedMouseEnter: anEvent for: aMorph
+
+ aMorph addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3).
+
+ !
Item was added:
+ ----- Method: Morph>>programmedMouseLeave:for: (in category 'debug and other') -----
+ programmedMouseLeave: anEvent for: aMorph
+
+ self deleteAnyMouseActionIndicators.
+ !
Item was added:
+ ----- Method: Morph>>programmedMouseUp:for: (in category 'debug and other') -----
+ programmedMouseUp: anEvent for: aMorph
+ | aCodeString |
+ self deleteAnyMouseActionIndicators.
+ aCodeString := self valueOfProperty: #mouseUpCodeToRun ifAbsent: [^self].
+ (self fullBounds containsPoint: anEvent cursorPoint) ifFalse: [^self].
+
+ [(aCodeString isMessageSend)
+ ifTrue: [aCodeString value]
+ ifFalse:
+ [Compiler
+ evaluate: aCodeString
+ for: self
+ notifying: nil]]
+ on: ProgressTargetRequestNotification
+ do: [:ex | ex resume: self] "in case a save/load progress display needs a home"!
Item was added:
+ ----- Method: Morph>>raisedColor (in category 'accessing') -----
+ raisedColor
+ "Return the color to be used for shading raised borders. The
+ default is my own color, but it might want to be, eg, my
+ owner's color. Whoever's color ends up prevailing, the color
+ itself gets the last chance to determine, so that when, for
+ example, an InfiniteForm serves as the color, callers won't choke
+ on some non-Color object being returned"
+ (color isColor
+ and: [color isTransparent
+ and: [owner notNil]])
+ ifTrue: [^ owner raisedColor].
+ ^ color asColor raisedColor!
Item was added:
+ ----- Method: Morph>>randomBoundsFor: (in category 'WiW support') -----
+ randomBoundsFor: aMorph
+
+ | trialRect |
+ trialRect := (
+ self topLeft +
+ ((self width * (15 + 75 atRandom/100)) rounded @
+ (self height * (15 + 75 atRandom/100)) rounded)
+ ) extent: aMorph extent.
+ ^trialRect translateBy: (trialRect amountToTranslateWithin: self bounds)
+ !
Item was added:
+ ----- Method: Morph>>readoutForField: (in category 'thumbnail') -----
+ readoutForField: fieldSym
+ "Provide a readout that will show the value of the slot/pseudoslot of the receiver generated by sending fieldSym to the receiver"
+
+ | aContainer |
+ "still need to get this right"
+ aContainer := AlignmentMorph newColumn.
+ aContainer layoutInset: 0; hResizing: #rigid; vResizing: #shrinkWrap.
+ aContainer addMorphBack: (StringMorph new contents: (self perform: fieldSym) asString).
+ ^ aContainer!
Item was added:
+ ----- Method: Morph>>reasonableBitmapFillForms (in category 'menus') -----
+ reasonableBitmapFillForms
+ "Answer an OrderedCollection of forms that could be used to replace my bitmap fill, with my current form first."
+ | reasonableForms myGraphic |
+ reasonableForms := self class allSketchMorphForms.
+ reasonableForms addAll: Imports default images.
+ reasonableForms addAll: (BitmapFillStyle allSubInstances collect:[:f| f form]).
+ reasonableForms
+ remove: (myGraphic := self fillStyle form)
+ ifAbsent: [].
+ reasonableForms := reasonableForms asOrderedCollection.
+ reasonableForms addFirst: myGraphic.
+ ^reasonableForms!
Item was added:
+ ----- Method: Morph>>reasonableForms (in category 'menus') -----
+ reasonableForms
+ "Answer an OrderedCollection of forms that could be used to replace my form, with my current form first."
+ | reasonableForms myGraphic |
+ reasonableForms := self class allSketchMorphForms.
+ reasonableForms addAll: Imports default images.
+ reasonableForms
+ remove: (myGraphic := self form)
+ ifAbsent: [].
+ reasonableForms := reasonableForms asOrderedCollection.
+ reasonableForms addFirst: myGraphic.
+ ^reasonableForms!
Item was added:
+ ----- Method: Morph>>redButtonGestureDictionaryOrName: (in category 'geniestubs') -----
+ redButtonGestureDictionaryOrName: aSymbolOrDictionary!
Item was added:
+ ----- Method: Morph>>referencePlayfield (in category 'e-toy support') -----
+ referencePlayfield
+ "Answer the PasteUpMorph to be used for cartesian-coordinate reference"
+
+ | former |
+ owner ifNotNil:
+ [(self topRendererOrSelf owner isHandMorph and: [(former := self formerOwner) notNil])
+ ifTrue:
+ [former := former renderedMorph.
+ ^ former isPlayfieldLike
+ ifTrue: [former]
+ ifFalse: [former referencePlayfield]]].
+
+ self allOwnersDo: [:o | o isPlayfieldLike ifTrue: [^ o]].
+ ^ ActiveWorld!
Item was added:
+ ----- Method: Morph>>refreshWorld (in category 'drawing') -----
+ refreshWorld
+ | aWorld |
+ (aWorld := self world) ifNotNil: [aWorld displayWorldSafely]
+ !
Item was added:
+ ----- Method: Morph>>regularColor (in category 'accessing') -----
+ regularColor
+
+ | val |
+ ^ (val := self valueOfProperty: #regularColor)
+ ifNotNil:
+ [val ifNil: [self error: 'nil regularColor']]
+ ifNil:
+ [owner ifNil: [self color] ifNotNil: [owner regularColor]]!
Item was added:
+ ----- Method: Morph>>regularColor: (in category 'accessing') -----
+ regularColor: aColor
+ self setProperty: #regularColor toValue: aColor!
Item was added:
+ ----- Method: Morph>>rejectDropEvent: (in category 'events-processing') -----
+ rejectDropEvent: anEvent
+ "This hook allows the receiver to repel a drop operation currently executed. The method is called prior to checking children so the receiver must validate that the event was really designated for it.
+ Note that the ordering of the tests below is designed to avoid a (possibly expensive) #fullContainsPoint: test. If the receiver doesn't want to repel the morph anyways we don't need to check after all."
+ (self repelsMorph: anEvent contents event: anEvent) ifFalse:[^self]. "not repelled"
+ (self fullContainsPoint: anEvent position) ifFalse:[^self]. "not for me"
+ "Throw it away"
+ anEvent wasHandled: true.
+ anEvent contents rejectDropMorphEvent: anEvent.!
Item was added:
+ ----- Method: Morph>>rejectDropMorphEvent: (in category 'dropping/grabbing') -----
+ rejectDropMorphEvent: evt
+ "The receiver has been rejected, and must be put back somewhere. There are three cases:
+ (1) It remembers its former owner and position, and goes right back there
+ (2) It remembers its former position only, in which case it was torn off from a parts bin, and the UI is that it floats back to its donor position and then vanishes.
+ (3) Neither former owner nor position is remembered, in which case it is whisked to the Trash"
+
+ self removeProperty: #undoGrabCommand.
+ (self formerOwner notNil and: [self formerOwner isPartsBin not]) ifTrue:
+ [^ self slideBackToFormerSituation: evt].
+
+ self formerPosition ifNotNil: "Position but no owner -- can just make it vanish"
+ [^ self vanishAfterSlidingTo: self formerPosition event: evt].
+
+ self slideToTrash: evt!
Item was added:
+ ----- Method: Morph>>rejectsEvent: (in category 'events-processing') -----
+ rejectsEvent: anEvent
+ "Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it."
+ ^self isLocked or:[self visible not]!
Item was added:
+ ----- Method: Morph>>relativeTextAnchorPosition (in category 'text-anchor') -----
+ relativeTextAnchorPosition
+ ^self valueOfProperty: #relativeTextAnchorPosition!
Item was added:
+ ----- Method: Morph>>relativeTextAnchorPosition: (in category 'text-anchor') -----
+ relativeTextAnchorPosition: aPoint
+ ^self setProperty: #relativeTextAnchorPosition toValue: aPoint!
Item was added:
+ ----- Method: Morph>>releaseActionMap (in category 'events-removing') -----
+ releaseActionMap
+ "Release the action map"
+
+ self removeProperty: #actionMap!
Item was added:
+ ----- Method: Morph>>releaseCachedState (in category 'caching') -----
+ releaseCachedState
+ "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'."
+ self borderStyle releaseCachedState.
+ !
Item was added:
+ ----- Method: Morph>>rememberedColor (in category 'accessing') -----
+ rememberedColor
+ "Answer a rememberedColor, or nil if none"
+
+ ^ self valueOfProperty: #rememberedColor ifAbsent: [nil]!
Item was added:
+ ----- Method: Morph>>rememberedColor: (in category 'accessing') -----
+ rememberedColor: aColor
+ "Place aColor in a property so I can retrieve it later. A tortuous but expedient flow of data"
+
+ ^ self setProperty: #rememberedColor toValue: aColor!
Item was added:
+ ----- Method: Morph>>removeAlarm: (in category 'events-alarms') -----
+ removeAlarm: aSelector
+ "Remove the given alarm"
+ | scheduler |
+ scheduler := self alarmScheduler.
+ scheduler ifNotNil:[scheduler removeAlarm: aSelector for: self].!
Item was added:
+ ----- Method: Morph>>removeAlarm:at: (in category 'events-alarms') -----
+ removeAlarm: aSelector at: scheduledTime
+ "Remove the given alarm"
+ | scheduler |
+ scheduler := self alarmScheduler.
+ scheduler ifNotNil:[scheduler removeAlarm: aSelector at: scheduledTime for: self].!
Item was added:
+ ----- Method: Morph>>removeAllButFirstSubmorph (in category 'other') -----
+ removeAllButFirstSubmorph
+ "Remove all of the receiver's submorphs other than the first one."
+
+ self submorphs allButFirst do: [:m | m delete]!
Item was added:
+ ----- Method: Morph>>removeAllMorphs (in category 'submorphs-add/remove') -----
+ removeAllMorphs
+ | oldMorphs myWorld |
+ myWorld := self world.
+ (fullBounds notNil or: [ myWorld notNil ]) ifTrue: [ self invalidRect: self fullBounds ].
+ submorphs do:
+ [ : m | myWorld ifNotNil: [ m outOfWorld: myWorld ].
+ m privateOwner: nil ].
+ oldMorphs := submorphs.
+ submorphs := Array empty.
+ oldMorphs do: [ : m | self removedMorph: m ].
+ self layoutChanged!
Item was added:
+ ----- Method: Morph>>removeAllMorphsIn: (in category 'submorphs-add/remove') -----
+ removeAllMorphsIn: aCollection
+ "greatly speeds up the removal of *lots* of submorphs"
+ | set myWorld |
+ set := IdentitySet new: aCollection size * 4 // 3.
+ aCollection do: [:each | each owner == self ifTrue: [ set add: each]].
+ myWorld := self world.
+ (fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds].
+ set do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil].
+ submorphs := submorphs reject: [ :each | set includes: each].
+ set do: [ :m | self removedMorph: m ].
+ self layoutChanged.
+ !
Item was added:
+ ----- Method: Morph>>removeDropShadow (in category 'drop shadows') -----
+ removeDropShadow
+ self hasDropShadow ifFalse:[^self].
+ self changed.
+ self hasDropShadow: false.
+ fullBounds ifNotNil:[fullBounds := self privateFullBounds].
+ self changed.!
Item was added:
+ ----- Method: Morph>>removeFlexShell (in category 'rotate scale and flex') -----
+ removeFlexShell
+ self isFlexed
+ ifTrue: [self owner removeFlexShell]!
Item was added:
+ ----- Method: Morph>>removeHalo (in category 'halos and balloon help') -----
+ removeHalo
+ "remove the surrounding halo (if any)"
+ self halo isNil
+ ifFalse: [self primaryHand removeHalo]!
Item was added:
+ ----- Method: Morph>>removeLink: (in category 'event handling') -----
+ removeLink: actionCode
+ self eventHandler ifNotNil:
+ [self eventHandler on: actionCode send: nil to: nil]!
Item was added:
+ ----- Method: Morph>>removeMorph: (in category 'submorphs-add/remove') -----
+ removeMorph: aMorph
+ "Remove the given morph from my submorphs"
+ | aWorld |
+ aMorph owner == self ifFalse:[^self].
+ aWorld := self world.
+ aWorld ifNotNil:[
+ aMorph outOfWorld: aWorld.
+ self privateInvalidateMorph: aMorph.
+ ].
+ self privateRemove: aMorph.
+ aMorph privateOwner: nil.
+ self removedMorph: aMorph.
+ !
Item was added:
+ ----- Method: Morph>>removeMouseUpAction (in category 'debug and other') -----
+ removeMouseUpAction
+
+ self primaryHand showTemporaryCursor: nil.
+ self removeProperty: #mouseUpCodeToRun.
+ #(mouseUp mouseEnter mouseLeave mouseDown) do: [ :sym |
+ self
+ on: sym
+ send: #yourself
+ to: nil.
+ ]
+
+ !
Item was added:
+ ----- Method: Morph>>removeProperty: (in category 'accessing - properties') -----
+ removeProperty: aSymbol
+ "removes the property named aSymbol if it exists"
+ extension ifNil: [^ self].
+ extension removeProperty: aSymbol!
Item was added:
+ ----- Method: Morph>>removedMorph: (in category 'submorphs-add/remove') -----
+ removedMorph: aMorph
+ "Notify the receiver that aMorph was just removed from its children"
+ !
Item was added:
+ ----- Method: Morph>>renameInternal: (in category 'testing') -----
+ renameInternal: aName
+ "Change the internal name (because of a conflict) but leave the external name unchanged. Change Player class name, but do not change the names that appear in tiles. When coming in from disk, and have name conflict, References will already have the new name. "
+
+ self knownName = aName ifTrue: [^ aName].
+ self topRendererOrSelf setNameTo: aName.
+
+ "References dictionary already has key aName"
+
+ "If this player has a viewer flap, it will remain present"
+
+ "Tiles in scripts all stay the same"
+
+ "Compiled methods for scripts have been fixed up because the same association was reused"
+
+ ^ aName!
Item was added:
+ ----- Method: Morph>>renameTo: (in category 'testing') -----
+ renameTo: aName
+ "Set Player name in costume. Update Viewers. Fix all tiles (old style). fix
+ References. New tiles: recompile, and recreate open scripts. If coming in
+ from disk, and have name conflict, References will already have new
+ name."
+ | aPresenter putInViewer aPasteUp renderer oldKey assoc classes oldName |
+ oldName := self knownName.
+ oldName=aName ifTrue: [ ^aName ].
+ (renderer := self topRendererOrSelf) setNameTo: aName.
+ putInViewer := false.
+ ((aPresenter := self presenter) isNil or: [renderer player isNil])
+ ifFalse:
+ [putInViewer := aPresenter currentlyViewing: renderer player.
+ putInViewer ifTrue: [renderer player viewerFlapTab hibernate]].
+ "empty it temporarily"
+ (aPasteUp := self topPasteUp)
+ ifNotNil: [aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]].
+ "Fix References dictionary. See restoreReferences to know why oldKey is
+ already aName, but oldName is the old name."
+ oldKey := References keyAtIdentityValue: renderer player ifAbsent: [].
+ oldKey ifNotNil:
+ [assoc := References associationAt: oldKey.
+ oldKey = aName
+ ifFalse:
+ ["normal rename"
+
+ assoc key: (renderer player uniqueNameForReferenceFrom: aName).
+ References rehash]].
+ putInViewer ifTrue: [aPresenter viewMorph: self].
+ "recreate my viewer"
+ oldKey ifNil: [^aName].
+ "Force strings in tiles to be remade with new name. New tiles only."
+ Preferences universalTiles ifFalse: [^aName].
+ classes := (self systemNavigation allCallsOn: assoc)
+ collect: [:each | each classSymbol].
+ classes asSet
+ do: [:clsName | (Smalltalk at: clsName) replaceSilently: oldName to: aName].
+ "replace in text body of all methods. Can be wrong!!"
+ "Redo the tiles that are showing. This is also done in caller in
+ unhibernate. "
+ aPasteUp ifNotNil:
+ [aPasteUp allTileScriptingElements do:
+ [:mm |
+ "just ScriptEditorMorphs"
+
+ nil.
+ (mm isScriptEditorMorph)
+ ifTrue:
+ [((mm playerScripted class compiledMethodAt: mm scriptName)
+ hasLiteral: assoc)
+ ifTrue:
+ [mm
+ hibernate;
+ unhibernate]]]].
+ ^aName!
Item was added:
+ ----- Method: Morph>>renderedMorph (in category 'structure') -----
+ renderedMorph
+ "This now gets overridden by rendering morphs."
+
+ ^self!
Item was added:
+ ----- Method: Morph>>repelsMorph:event: (in category 'dropping/grabbing') -----
+ repelsMorph: aMorph event: ev
+ ^ false!
Item was added:
+ ----- Method: Morph>>replaceSubmorph:by: (in category 'submorphs-add/remove') -----
+ replaceSubmorph: oldMorph by: newMorph
+ | index itsPosition w |
+ oldMorph stopStepping.
+ itsPosition := oldMorph referencePositionInWorld.
+ index := submorphs indexOf: oldMorph.
+ oldMorph privateDelete.
+ self privateAddMorph: newMorph atIndex: index.
+ newMorph referencePositionInWorld: itsPosition.
+ (w := newMorph world) ifNotNil:
+ [w startSteppingSubmorphsOf: newMorph]!
Item was added:
+ ----- Method: Morph>>reportableSize (in category 'printing') -----
+ reportableSize
+ "Answer a size worth reporting as the receiver's size in a list view"
+
+ | total |
+ total := super reportableSize.
+ submorphs do:
+ [:m | total := total + m reportableSize].
+ ^ total!
Item was added:
+ ----- Method: Morph>>representativeNoTallerThan:norWiderThan:thumbnailHeight: (in category 'thumbnail') -----
+ representativeNoTallerThan: maxHeight norWiderThan: maxWidth thumbnailHeight: thumbnailHeight
+ "Return a morph representing the receiver but which is no taller than aHeight. If the receiver is already small enough, just return it, else return a MorphThumbnail companioned to the receiver, enforcing the maxWidth. If the receiver personally *demands* thumbnailing, do it even if there is no size-related reason to do it."
+
+ self demandsThumbnailing ifFalse:
+ [self permitsThumbnailing ifFalse: [^ self].
+ (self fullBounds height <= maxHeight and: [self fullBounds width <= maxWidth]) ifTrue: [^ self]].
+
+ ^ MorphThumbnail new extent: maxWidth @ (thumbnailHeight min: self fullBounds height); morphRepresented: self!
Item was added:
+ ----- Method: Morph>>reserveUrl: (in category 'fileIn/out') -----
+ reserveUrl: urlString
+ "Write a dummy object to the server to hold a name and place for this object."
+
+ | dummy ext str |
+ dummy := PasteUpMorph new.
+ dummy borderWidth: 2.
+ dummy setProperty: #initialExtent toValue: (ext := 300 at 100).
+ dummy topLeft: 50 at 50; extent: ext. "reset when comes in"
+ str := (TextMorph new) topLeft: dummy topLeft + (10 at 10);
+ extent: dummy width - 15 @ 30.
+ dummy addMorph: str.
+ str contents: 'This is a place holder only. Please \find the original page and choose \"send this page to server"' withCRs.
+ str extent: dummy width - 15 @ 30.
+ dummy saveOnURL: urlString.
+
+ "Claim that url myself"
+ self setProperty: #SqueakPage toValue: dummy sqkPage.
+ (dummy sqkPage) contentsMorph: self; dirty: true.
+ ^ self url!
Item was added:
+ ----- Method: Morph>>resetExtension (in category 'accessing - extension') -----
+ resetExtension
+ "reset the extension slot if it is not needed"
+ (extension notNil and: [extension isDefault]) ifTrue: [extension := nil] !
Item was added:
+ ----- Method: Morph>>resetForwardDirection (in category 'menus') -----
+ resetForwardDirection
+ self forwardDirection: 0.!
Item was added:
+ ----- Method: Morph>>resetFrom: (in category '*Morphic-Sound-piano rolls') -----
+ resetFrom: scorePlayer
+
+ "subclasses should revert to their initial state"!
Item was added:
+ ----- Method: Morph>>resetHighlightForDrop (in category 'dropping/grabbing') -----
+ resetHighlightForDrop
+ self highlightForDrop: false!
Item was added:
+ ----- Method: Morph>>residesInPartsBin (in category 'parts bin') -----
+ residesInPartsBin
+ "Answer true if the receiver is, or has some ancestor owner who is, a parts bin"
+ ^ owner ifNotNil: [owner residesInPartsBin] ifNil: [false]!
Item was added:
+ ----- Method: Morph>>resistsRemoval (in category 'accessing') -----
+ resistsRemoval
+ "Answer whether the receiver is marked as resisting removal"
+
+ ^ self hasProperty: #resistsRemoval!
Item was added:
+ ----- Method: Morph>>resistsRemoval: (in category 'accessing') -----
+ resistsRemoval: aBoolean
+ "Set the receiver's resistsRemoval property as indicated"
+
+ aBoolean
+ ifTrue:
+ [self setProperty: #resistsRemoval toValue: true]
+ ifFalse:
+ [self removeProperty: #resistsRemoval]!
Item was added:
+ ----- Method: Morph>>resistsRemovalString (in category 'menus') -----
+ resistsRemovalString
+ "Answer the string to be shown in a menu to represent the
+ 'resistsRemoval' status"
+ ^ (self resistsRemoval
+ ifTrue: ['<on>']
+ ifFalse: ['<off>']), 'resist being deleted' translated!
Item was added:
+ ----- Method: Morph>>resizeFromMenu (in category 'meta-actions') -----
+ resizeFromMenu
+ "Commence an interaction that will resize the receiver"
+
+ self resizeMorph: ActiveEvent!
Item was added:
+ ----- Method: Morph>>resizeMorph: (in category 'meta-actions') -----
+ resizeMorph: evt
+ | handle |
+ handle := HandleMorph new forEachPointDo: [:newPoint |
+ self extent: (self griddedPoint: newPoint) - self bounds topLeft].
+ evt hand attachMorph: handle.
+ handle startStepping.
+ !
Item was added:
+ ----- Method: Morph>>resourceJustLoaded (in category 'initialization') -----
+ resourceJustLoaded
+ "In case resource relates to me"
+ self releaseCachedState.!
Item was added:
+ ----- Method: Morph>>restoreSuspendedEventHandler (in category 'event handling') -----
+ restoreSuspendedEventHandler
+ | savedHandler |
+ (savedHandler := self valueOfProperty: #suspendedEventHandler) ifNotNil:
+ [self eventHandler: savedHandler].
+ submorphs do: [:m | m restoreSuspendedEventHandler]
+ !
Item was added:
+ ----- Method: Morph>>resumeAfterDrawError (in category 'debug and other') -----
+ resumeAfterDrawError
+
+ self changed.
+ self removeProperty:#errorOnDraw.
+ self changed.!
Item was added:
+ ----- Method: Morph>>resumeAfterStepError (in category 'debug and other') -----
+ resumeAfterStepError
+ "Resume stepping after an error has occured."
+
+ self startStepping. "Will #step"
+ self removeProperty:#errorOnStep. "Will remove prop only if #step was okay"
+ !
Item was added:
+ ----- Method: Morph>>resumeFrom: (in category '*Morphic-Sound-piano rolls') -----
+ resumeFrom: scorePlayer
+
+ "subclasses should continue from their current position"
+ "a hack to allow for abitrary morphs to be dropped into piano roll"!
Item was added:
+ ----- Method: Morph>>reverseTableCells (in category 'layout-properties') -----
+ reverseTableCells
+ "Layout specific. This property describes if the cells should be treated in reverse order of submorphs."
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[false] ifNotNil:[props reverseTableCells].!
Item was added:
+ ----- Method: Morph>>reverseTableCells: (in category 'layout-properties') -----
+ reverseTableCells: aBool
+ "Layout specific. This property describes if the cells should be treated in reverse order of submorphs."
+ self assureTableProperties reverseTableCells: aBool.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>right (in category 'geometry') -----
+ right
+ " Return the x-coordinate of my right side "
+ ^ bounds right!
Item was added:
+ ----- Method: Morph>>right: (in category 'geometry') -----
+ right: aNumber
+ " Move me so that my right side is at the x-coordinate aNumber. My extent (width & height) are unchanged "
+
+ self position: ((aNumber - bounds width) @ bounds top)!
Item was added:
+ ----- Method: Morph>>rightCenter (in category 'geometry') -----
+ rightCenter
+
+ ^ bounds rightCenter!
Item was added:
+ ----- Method: Morph>>root (in category 'structure') -----
+ root
+ "Return the root of the composite morph containing the receiver. The owner of the root is either nil, a WorldMorph, or a HandMorph. If the receiver's owner is nil, the root is the receiver itself. This method always returns a morph."
+
+ (owner isNil or: [owner isWorldOrHandMorph]) ifTrue: [^self].
+ ^owner root!
Item was added:
+ ----- Method: Morph>>rootAt: (in category 'structure') -----
+ rootAt: location
+ "Just return myself, unless I am a WorldWindow.
+ If so, then return the appropriate root in that world"
+
+ ^ self!
Item was added:
+ ----- Method: Morph>>rootMorphsAt: (in category 'submorphs-accessing') -----
+ rootMorphsAt: aPoint
+ "Return the list of root morphs containing the given point, excluding the receiver.
+ ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds"
+ self flag: #arNote. "check this at some point"
+ ^ self submorphs select:
+ [:m | (m fullContainsPoint: aPoint) and: [m isLocked not]]!
Item was added:
+ ----- Method: Morph>>rootMorphsAtGlobal: (in category 'submorphs-accessing') -----
+ rootMorphsAtGlobal: aPoint
+ "Return the list of root morphs containing the given point, excluding the receiver.
+ ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds"
+
+ ^ self rootMorphsAt: (self pointFromWorld: aPoint)!
Item was added:
+ ----- Method: Morph>>rotationDegrees (in category 'rotate scale and flex') -----
+ rotationDegrees
+ "Default implementation."
+
+ ^ 0.0
+ !
Item was added:
+ ----- Method: Morph>>rotationStyle (in category 'e-toy support') -----
+ rotationStyle
+ "Return the 'rotation style' of the receiver"
+ ^#normal!
Item was added:
+ ----- Method: Morph>>rotationStyle: (in category 'e-toy support') -----
+ rotationStyle: aSymbol
+ "Set the 'rotation style' of the receiver; this is ignored for non-sketches"!
Item was added:
+ ----- Method: Morph>>roundUpStrays (in category 'miscellaneous') -----
+ roundUpStrays
+ self submorphs
+ do: [:each | each roundUpStrays]!
Item was added:
+ ----- Method: Morph>>roundedCorners (in category 'rounding') -----
+ roundedCorners
+ "Return a list of those corners to round.
+
+ 1-4
+ | |
+ 2-3
+
+ Returned array contains `codes' of those corners, which should be rounded.
+
+ 1 denotes top-left corner
+ 2 denotes bottom-left corner
+ 3 denotes bottom-right corner
+ 4 denotes top-right corner.
+
+ Thus, if this method returned #(2 3) that would mean that bottom (left and right)
+ corners would be rounded whereas top (left and right) corners wouldn't be rounded.
+
+ This method returns #(1 2 3 4) and that means that all the corners should be rounded."
+
+ ^ #(1 2 3 4)!
Item was added:
+ ----- Method: Morph>>roundedCornersString (in category 'rounding') -----
+ roundedCornersString
+ "Answer the string to put in a menu that will invite the user to
+ switch to the opposite corner-rounding mode"
+ ^ (self wantsRoundedCorners
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ , 'round corners' translated!
Item was added:
+ ----- Method: Morph>>rubberBandCells (in category 'layout-properties') -----
+ rubberBandCells
+ "Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow."
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[false] ifNotNil:[props rubberBandCells].!
Item was added:
+ ----- Method: Morph>>rubberBandCells: (in category 'layout-properties') -----
+ rubberBandCells: aBool
+ "Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow."
+ self assureTableProperties rubberBandCells: aBool.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>saveAsPrototype (in category 'meta-actions') -----
+ saveAsPrototype
+ (UIManager default confirm: 'Make this morph the prototype for ', self class printString, '?')
+ ifFalse: [^ self].
+ self class prototype: self.
+ !
Item was added:
+ ----- Method: Morph>>saveAsResource (in category 'fileIn/out') -----
+ saveAsResource
+
+ | pathName |
+ (self hasProperty: #resourceFilePath) ifFalse: [^ self].
+ pathName := self valueOfProperty: #resourceFilePath.
+ (pathName asLowercase endsWith: '.morph') ifFalse:
+ [^ self error: 'Can only update morphic resources'].
+ (FileStream newFileNamed: pathName) fileOutClass: nil andObject: self.!
Item was added:
+ ----- Method: Morph>>saveDocPane (in category 'fileIn/out') -----
+ saveDocPane
+
+ Smalltalk at: #DocLibrary ifPresent:[:dl| dl external saveDocCheck: self]!
Item was added:
+ ----- Method: Morph>>saveOnFile (in category 'fileIn/out') -----
+ saveOnFile
+ "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out."
+ | aFileName ok |
+ aFileName := ('my {1}' translated format: {self class name}) asFileName. "do better?"
+ aFileName := UIManager default request: 'File name? (".morph" will be added to end)' translated
+ initialAnswer: aFileName.
+ aFileName isEmpty ifTrue: [^ Beeper beep].
+ self allMorphsDo: [:m | m prepareToBeSaved].
+
+ ok := aFileName endsWith: '.morph'. "don't double them"
+ ok := ok | (aFileName endsWith: '.sp').
+ ok ifFalse: [aFileName := aFileName,'.morph'].
+ self saveOnFileNamed: aFileName!
Item was added:
+ ----- Method: Morph>>saveOnURL (in category 'fileIn/out') -----
+ saveOnURL
+ "Ask the user for a url and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out."
+
+ | um pg |
+ (pg := self saveOnURLbasic) == #cancel ifTrue: [^ self].
+ um := URLMorph newForURL: pg url.
+ um setURL: pg url page: pg.
+ pg isContentsInMemory ifTrue: [pg computeThumbnail].
+ um isBookmark: true.
+ um removeAllMorphs.
+ um color: Color transparent.
+ self primaryHand attachMorph: um.!
Item was added:
+ ----- Method: Morph>>saveOnURL: (in category 'fileIn/out') -----
+ saveOnURL: suggestedUrlString
+ "Save myself on a SmartReferenceStream file. If I don't already have a url, use the suggested one. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out."
+ | url pg stamp pol |
+ (pg := self valueOfProperty: #SqueakPage)
+ ifNil: [ pg := SqueakPage new ]
+ ifNotNil:
+ [ pg contentsMorph ~~ self ifTrue:
+ [ self inform: 'morph''s SqueakPage property is out of date'.
+ pg := SqueakPage new ] ].
+ (url := pg url) ifNil: [ url := pg urlNoOverwrite: suggestedUrlString ].
+ stamp := Utilities authorInitialsPerSe.
+ stamp isEmptyOrNil ifTrue: [ stamp := '*' ].
+ pg
+ saveMorph: self
+ author: stamp.
+ SqueakPageCache
+ atURL: url
+ put: pg.
+ "setProperty: #SqueakPage"
+ (pol := pg policy) ifNil: [ pol := #neverWrite ].
+ pg
+ policy: #now ;
+ dirty: true.
+ pg write.
+ "force the write"
+ pg policy: pol.
+ ^pg!
Item was added:
+ ----- Method: Morph>>saveOnURLbasic (in category 'fileIn/out') -----
+ saveOnURLbasic
+ "Ask the user for a url and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out."
+
+ | url pg stamp pol |
+ (pg := self valueOfProperty: #SqueakPage) ifNil: [pg := SqueakPage new]
+ ifNotNil:
+ [pg contentsMorph ~~ self
+ ifTrue:
+ [self inform: 'morph''s SqueakPage property is out of date'.
+ pg := SqueakPage new]].
+ (url := pg url) ifNil:
+ [url := ServerDirectory defaultStemUrl , '1.sp'. "A new legal place"
+ url := UIManager default
+ request: 'url of a place to store this object.
+ Must begin with file:// or ftp://'
+ initialAnswer: url.
+ url isEmpty ifTrue: [^#cancel]].
+ stamp := Utilities authorInitialsPerSe.
+ stamp isEmptyOrNil ifTrue: [ stamp := '*' ].
+ pg saveMorph: self author: stamp.
+ SqueakPageCache atURL: url put: pg. "setProperty: #SqueakPage"
+ (pol := pg policy) ifNil: [pol := #neverWrite].
+ pg
+ policy: #now;
+ dirty: true.
+ pg write. "force the write"
+ pg policy: pol.
+ ^pg!
Item was added:
+ ----- Method: Morph>>scaleFactor (in category 'accessing') -----
+ scaleFactor
+ ^self valueOfProperty: #scaleFactor ifAbsent: [ 1.0 ]
+ !
Item was added:
+ ----- Method: Morph>>screenLocation (in category 'geometry') -----
+ screenLocation
+ "For compatibility only"
+
+ ^ self fullBounds origin!
Item was added:
+ ----- Method: Morph>>screenRectangle (in category 'geometry') -----
+ screenRectangle
+ "For compatibility only"
+
+ ^ self fullBounds!
Item was added:
+ ----- Method: Morph>>selectedObject (in category 'selected object') -----
+ selectedObject
+ "answer the selected object for the hand or nil is none"
+ ^ self primaryHand selectedObject!
Item was added:
+ ----- Method: Morph>>separateDragAndDrop (in category 'dropping/grabbing') -----
+ separateDragAndDrop
+ "Conversion only. Separate the old #dragNDropEnabled into #dragEnabled and #dropEnabled and remove the old property."
+ | dnd |
+ (self hasProperty: #dragNDropEnabled) ifFalse:[^self].
+ dnd := (self valueOfProperty: #dragNDropEnabled) == true.
+ self dragEnabled: dnd.
+ self dropEnabled: dnd.
+ self removeProperty: #dragNDropEnabled.
+ !
Item was added:
+ ----- Method: Morph>>setArrowheads (in category 'menus') -----
+ setArrowheads
+ "Let the user edit the size of arrowheads for this object"
+
+ | aParameter result |
+ aParameter := self renderedMorph valueOfProperty: #arrowSpec ifAbsent:
+ [Preferences parameterAt: #arrowSpec ifAbsent: [5 @ 4]].
+ result := Morph obtainArrowheadFor: 'Head size for arrowheads: ' translated defaultValue: aParameter asString.
+ result ifNotNil:
+ [self renderedMorph setProperty: #arrowSpec toValue: result]
+ ifNil:
+ [Beeper beep]!
Item was added:
+ ----- Method: Morph>>setAsActionInButtonProperties: (in category 'e-toy support') -----
+ setAsActionInButtonProperties: buttonProperties
+
+ ^false "means I don't know how to be set as a button action"!
Item was added:
+ ----- Method: Morph>>setBalloonText: (in category 'halos and balloon help') -----
+ setBalloonText: stringOrText
+ "Set receiver's balloon help text. Pass nil to remove the help."
+
+ self flag: #deprecated. "mt: Use #balloonText:."
+ self balloonText: stringOrText.!
Item was added:
+ ----- Method: Morph>>setBalloonText:maxLineLength: (in category 'halos and balloon help') -----
+ setBalloonText: stringOrText maxLineLength: aLength
+ "Set receiver's balloon help text. Pass nil to remove the help."
+
+ self flag: #deprecated. "mt: Use #balloonText:."
+ (extension isNil and: [stringOrText isNil]) ifTrue: [^ self].
+ self assureExtension balloonText:
+ (stringOrText ifNotNil: [stringOrText asString withNoLineLongerThan: aLength])!
Item was added:
+ ----- Method: Morph>>setBorderStyle: (in category 'accessing') -----
+ setBorderStyle: aSymbol
+ "Set the border style of my costume"
+
+ | aStyle |
+ aStyle := self borderStyleForSymbol: aSymbol.
+ aStyle ifNil: [^ self].
+ (self canDrawBorder: aStyle)
+ ifTrue:
+ [self borderStyle: aStyle]!
Item was added:
+ ----- Method: Morph>>setCenteredBalloonText: (in category 'halos and balloon help') -----
+ setCenteredBalloonText: aString
+ self setBalloonText: aString.
+ self setProperty: #helpAtCenter toValue: true!
Item was added:
+ ----- Method: Morph>>setConstrainedPosition:hangOut: (in category 'geometry') -----
+ setConstrainedPosition: aPoint hangOut: partiallyOutside
+ "Change the position of this morph and and all of its submorphs to aPoint, but don't let me go outside my owner's bounds. Let me go within two pixels of completely outside if partiallyOutside is true."
+
+ | trialRect delta boundingMorph bRect |
+ owner ifNil:[^self].
+ trialRect := aPoint extent: self bounds extent.
+ boundingMorph := self topRendererOrSelf owner.
+ delta := boundingMorph
+ ifNil: [0 at 0]
+ ifNotNil: [
+ bRect := partiallyOutside
+ ifTrue: [boundingMorph bounds insetBy:
+ self extent negated + boundingMorph borderWidth + (2 at 2)]
+ ifFalse: [boundingMorph bounds].
+ trialRect amountToTranslateWithin: bRect].
+ self position: aPoint + delta.
+ self layoutChanged "So that, eg, surrounding text will readjust"
+ !
Item was added:
+ ----- Method: Morph>>setExtentFromHalo: (in category 'miscellaneous') -----
+ setExtentFromHalo: anExtent
+ "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed"
+
+ self extent: anExtent!
Item was added:
+ ----- Method: Morph>>setFlexExtentFromHalo: (in category 'miscellaneous') -----
+ setFlexExtentFromHalo: anExtent
+ "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed. Set the extent of the top renderer as indicated."
+
+ self addFlexShellIfNecessary.
+ self topRendererOrSelf extent: anExtent!
Item was added:
+ ----- Method: Morph>>setNamePropertyTo: (in category 'naming') -----
+ setNamePropertyTo: aName
+ "change the receiver's externalName"
+ self assureExtension externalName: aName!
Item was added:
+ ----- Method: Morph>>setNameTo: (in category 'naming') -----
+ setNameTo: aName
+ | nameToUse nameString |
+ nameToUse := aName ifNotNil:
+ [(nameString := aName asString) notEmpty ifTrue: [nameString] ifFalse: ['*']].
+ self setNamePropertyTo: nameToUse "no Texts here!!"!
Item was added:
+ ----- Method: Morph>>setNumericValue: (in category 'e-toy support') -----
+ setNumericValue: aValue
+ "Set the receiver's contents to reflect the given numeric value. Only certain kinds of morphs know what to do with this, the rest, for now, stash the number in a property, where it may not be visible but at least it won't be lost, and can be retrieved by the companion getter. This code is never reached under normal circumstances, because the #numericValue slot is not shown in Viewers for most kinds of morphs, and those kinds of morphs that do show it also reimplement this method. However, this code *could* be reached via a user script which sends #setNumericValue: but whose receiver has been changed, via tile-scripting drag and drop for example, to one that doesn't directly handle numbers"
+
+ ScriptingSystem informScriptingUser: 'an unusual setNumericValue: call was made'.
+ self renderedMorph setProperty: #numericValue toValue: aValue
+ !
Item was added:
+ ----- Method: Morph>>setProperties: (in category 'accessing - properties') -----
+ setProperties: aList
+ "Set many properties at once from a list of prop, value, prop, value"
+
+ 1 to: aList size by: 2 do: [:ii |
+ self setProperty: (aList at: ii) toValue: (aList at: ii+1)].!
Item was added:
+ ----- Method: Morph>>setProperty:toValue: (in category 'accessing - properties') -----
+ setProperty: aSymbol toValue: anObject
+ "change the receiver's property named aSymbol to anObject"
+ anObject ifNil: [^ self removeProperty: aSymbol].
+ self assureExtension setProperty: aSymbol toValue: anObject!
Item was added:
+ ----- Method: Morph>>setRotationCenter (in category 'menus') -----
+ setRotationCenter
+ | p |
+ self world displayWorld.
+ p := Cursor crossHair showWhile:
+ [Sensor waitButton].
+ Sensor waitNoButton.
+ self setRotationCenterFrom: (self transformFromWorld globalPointToLocal: p).
+
+ !
Item was added:
+ ----- Method: Morph>>setRotationCenterFrom: (in category 'menus') -----
+ setRotationCenterFrom: aPoint
+ self rotationCenter: (aPoint - self bounds origin) / self bounds extent asFloatPoint.!
Item was added:
+ ----- Method: Morph>>setShadowOffset: (in category 'drop shadows') -----
+ setShadowOffset: evt
+ | handle |
+ handle := HandleMorph new forEachPointDo:
+ [:newPoint | self shadowPoint: newPoint].
+ evt hand attachMorph: handle.
+ handle startStepping.
+ !
Item was added:
+ ----- Method: Morph>>setStandardTexture (in category 'e-toy support') -----
+ setStandardTexture
+ | parms |
+ parms := self textureParameters.
+ self makeGraphPaperGrid: parms first
+ background: parms second
+ line: parms third!
Item was added:
+ ----- Method: Morph>>setToAdhereToEdge: (in category 'menus') -----
+ setToAdhereToEdge: anEdge
+ anEdge ifNil: [^ self].
+ anEdge == #none ifTrue: [^ self removeProperty: #edgeToAdhereTo].
+ self setProperty: #edgeToAdhereTo toValue: anEdge.
+ !
Item was added:
+ ----- Method: Morph>>shadowColor (in category 'drop shadows') -----
+ shadowColor
+ ^self valueOfProperty: #shadowColor ifAbsent:[Color black]!
Item was added:
+ ----- Method: Morph>>shadowColor: (in category 'drop shadows') -----
+ shadowColor: aColor
+ self shadowColor = aColor ifTrue: [^ self].
+ self setProperty: #shadowColor toValue: aColor.
+ self removeProperty: #dropShadow.
+ self changed.!
Item was added:
+ ----- Method: Morph>>shadowForm (in category 'drawing') -----
+ shadowForm
+ "Return a form representing the 'shadow' of the receiver - e.g., all pixels that are occupied by the receiver are one, all others are zero."
+ | canvas |
+ canvas := (Display defaultCanvasClass extent: self fullBounds extent depth: 1)
+ asShadowDrawingCanvas: Color black. "Color black represents one for 1bpp"
+ canvas translateBy: bounds topLeft negated
+ during:[:tempCanvas| tempCanvas fullDrawMorph: self].
+ ^ canvas form offset: bounds topLeft
+ !
Item was added:
+ ----- Method: Morph>>shadowOffset (in category 'drop shadows') -----
+ shadowOffset
+ "Return the current shadow offset"
+ ^self valueOfProperty: #shadowOffset ifAbsent:[0 at 0]!
Item was added:
+ ----- Method: Morph>>shadowOffset: (in category 'drop shadows') -----
+ shadowOffset: aPoint
+ "Set the current shadow offset"
+
+ self shadowOffset = aPoint ifTrue: [^ self].
+ self changed.
+
+ (aPoint isNil or: [ aPoint isZero ])
+ ifTrue:[self removeProperty: #shadowOffset]
+ ifFalse:[self setProperty: #shadowOffset toValue: aPoint].
+
+ self layoutChanged.
+ self changed.!
Item was added:
+ ----- Method: Morph>>shadowPoint: (in category 'drop shadows') -----
+ shadowPoint: newPoint
+ self changed.
+ self shadowOffset: newPoint - self center // 5.
+ fullBounds ifNotNil:[fullBounds := self privateFullBounds].
+ self changed.!
Item was added:
+ ----- Method: Morph>>shiftSubmorphsOtherThan:by: (in category 'geometry') -----
+ shiftSubmorphsOtherThan: listNotToShift by: delta
+ | rejectList |
+ rejectList := listNotToShift ifNil: [OrderedCollection new].
+ (submorphs copyWithoutAll: rejectList) do:
+ [:m | m position: (m position + delta)]!
Item was added:
+ ----- Method: Morph>>shouldDropOnMouseUp (in category 'testing') -----
+ shouldDropOnMouseUp
+ | former |
+ former := self formerPosition ifNil:[^false].
+ ^(former dist: self position) > 10!
Item was added:
+ ----- Method: Morph>>shouldGetStepsFrom: (in category 'WiW support') -----
+ shouldGetStepsFrom: aWorld
+ ^self world == aWorld!
Item was added:
+ ----- Method: Morph>>shouldRememberCostumes (in category 'player') -----
+ shouldRememberCostumes
+ ^true!
Item was added:
+ ----- Method: Morph>>show (in category 'drawing') -----
+ show
+ "Make sure this morph is on-stage."
+ self visible ifFalse: [self visible: true. self changed]!
Item was added:
+ ----- Method: Morph>>showActions (in category 'meta-actions') -----
+ showActions
+ "Put up a message list browser of all the code that this morph
+ would run for mouseUp, mouseDown, mouseMove, mouseEnter,
+ mouseLeave, and
+ mouseLinger. tk 9/13/97"
+ | list cls selector adder |
+ list := SortedCollection new.
+ adder := [:mrClass :mrSel | list
+ add: (MethodReference class: mrClass selector: mrSel)].
+ "the eventHandler"
+ self eventHandler
+ ifNotNil: [list := self eventHandler methodRefList.
+ (self eventHandler handlesMouseDown: nil)
+ ifFalse: [adder value: HandMorph value: #grabMorph:]].
+ "If not those, then non-default raw events"
+ #(#keyStroke: #mouseDown: #mouseEnter: #mouseLeave: #mouseMove: #mouseUp: #doButtonAction )
+ do: [:sel |
+ cls := self class whichClassIncludesSelector: sel.
+ cls
+ ifNotNil: ["want more than default behavior"
+ cls == Morph
+ ifFalse: [adder value: cls value: sel]]].
+ "The mechanism on a Button"
+ (self respondsTo: #actionSelector)
+ ifTrue: ["A button"
+ selector := self actionSelector.
+ cls := self target class whichClassIncludesSelector: selector.
+ cls
+ ifNotNil: ["want more than default behavior"
+ cls == Morph
+ ifFalse: [adder value: cls value: selector]]].
+ MessageSet openMessageList: list name: 'Actions
+ of ' , self printString autoSelect: nil!
Item was added:
+ ----- Method: Morph>>showBalloon: (in category 'halos and balloon help') -----
+ showBalloon: msgString
+ "Pop up a balloon containing the given string,
+ first removing any existing BalloonMorphs in the world."
+ | w |
+ self showBalloon: msgString hand: ((w := self world) ifNotNil:[w activeHand]).!
Item was added:
+ ----- Method: Morph>>showBalloon:hand: (in category 'halos and balloon help') -----
+ showBalloon: msgString hand: aHand
+ "Pop up a balloon containing the given string,
+ first removing any existing BalloonMorphs in the world."
+
+ | w balloon h |
+ (w := self world) ifNil: [^ self].
+ h := aHand.
+ h ifNil:[
+ h := w activeHand].
+ balloon := self balloonMorphClass
+ string: msgString
+ for: self balloonHelpAligner.
+ balloon popUpFor: self hand: h.!
Item was added:
+ ----- Method: Morph>>showHiders (in category 'meta-actions') -----
+ showHiders
+ self allMorphsDo:[:m | m show]!
Item was added:
+ ----- Method: Morph>>shuffleSubmorphs (in category 'submorphs-accessing') -----
+ shuffleSubmorphs
+ "Randomly shuffle the order of my submorphs. Don't call this method lightly!!"
+
+ | bg |
+ self invalidRect: self fullBounds.
+ (submorphs notEmpty and: [submorphs last mustBeBackmost])
+ ifTrue:
+ [bg := submorphs last.
+ bg privateDelete].
+ submorphs := submorphs shuffled.
+ bg ifNotNil: [self addMorphBack: bg].
+ self layoutChanged!
Item was added:
+ ----- Method: Morph>>sightTargets: (in category 'meta-actions') -----
+ sightTargets: event
+ "Return the potential targets for the receiver.
+ This is derived from Morph>>potentialEmbeddingTargets."
+ | bullseye candidates choice |
+ owner ifNil: [^ #()].
+ bullseye := Point fromUserWithCursor: Cursor target.
+ candidates := self potentialTargetsAt: bullseye.
+ choice := UIManager default
+ chooseFrom: (candidates collect:[:m| m knownName ifNil:[m class name]])
+ values: candidates.
+ choice ifNotNil:[self target: choice].!
Item was added:
+ ----- Method: Morph>>sightWorldTargets: (in category 'meta-actions') -----
+ sightWorldTargets: event
+ "Return the potential targets for the receiver.
+ This is derived from Morph>>potentialEmbeddingTargets."
+ | bullseye myWorld candidates choice |
+ myWorld := self world ifNil: [^ #()].
+ bullseye := Point fromUserWithCursor: Cursor target.
+ candidates := myWorld morphsAt: bullseye.
+ choice := UIManager default
+ chooseFrom: (candidates collect:[:m| m knownName ifNil:[m class name]])
+ values: candidates.
+ choice ifNotNil:[self target: choice].!
Item was added:
+ ----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
+ slideBackToFormerSituation: evt
+ | slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
+ formerOwner := self formerOwner.
+ formerPosition := self formerPosition.
+ aWorld := evt hand world.
+ trans := formerOwner transformFromWorld.
+ slideForm := trans isPureTranslation
+ ifTrue: [self imageForm offset: 0 @ 0]
+ ifFalse:
+ [((TransformationMorph new asFlexOf: self) transform: trans) imageForm
+ offset: 0 @ 0].
+ startPoint := evt hand fullBounds origin.
+ endPoint := trans localPointToGlobal: formerPosition.
+ owner removeMorph: self.
+ aWorld displayWorld.
+ slideForm
+ slideFrom: startPoint
+ to: endPoint
+ nSteps: 12
+ delay: 15.
+ formerOwner addMorph: self.
+ self position: formerPosition.
+ self justDroppedInto: formerOwner event: evt!
Item was added:
+ ----- Method: Morph>>slideToTrash: (in category 'dropping/grabbing') -----
+ slideToTrash: evt
+ "Perhaps slide the receiver across the screen to a trash can and make it disappear into it. In any case, remove the receiver from the screen."
+
+ | aForm trash startPoint endPoint morphToSlide |
+ ((self renderedMorph == ScrapBook default scrapBook) or: [self renderedMorph isKindOf: TrashCanMorph]) ifTrue:
+ [self dismissMorph. ^ self].
+ TrashCanMorph slideDismissalsToTrash ifTrue:
+ [morphToSlide := self representativeNoTallerThan: 200 norWiderThan: 200 thumbnailHeight: 100.
+ aForm := morphToSlide imageForm offset: (0 at 0).
+ trash := ActiveWorld
+ findDeepSubmorphThat:
+ [:aMorph | (aMorph isKindOf: TrashCanMorph) and:
+ [aMorph topRendererOrSelf owner == ActiveWorld]]
+ ifAbsent:
+ [trash := TrashCanMorph new.
+ trash position: ActiveWorld bottomLeft - (0 @ (trash extent y + 26)).
+ trash openInWorld.
+ trash].
+ endPoint := trash fullBoundsInWorld center.
+ startPoint := self topRendererOrSelf fullBoundsInWorld center - (aForm extent // 2)].
+ self dismissMorph.
+ ActiveWorld displayWorld.
+ TrashCanMorph slideDismissalsToTrash ifTrue:
+ [aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15].
+ ScrapBook default addToTrash: self!
Item was added:
+ ----- Method: Morph>>snapToEdgeIfAppropriate (in category 'menus') -----
+ snapToEdgeIfAppropriate
+ | edgeSymbol oldBounds aWorld |
+ (edgeSymbol := self valueOfProperty: #edgeToAdhereTo) ifNotNil:
+ [oldBounds := bounds.
+ self adhereToEdge: edgeSymbol.
+ bounds ~= oldBounds ifTrue: [(aWorld := self world) ifNotNil: [aWorld viewBox ifNotNil:
+ [aWorld displayWorld]]]]!
Item was added:
+ ----- Method: Morph>>spaceFillWeight (in category 'layout-properties') -----
+ spaceFillWeight
+ "Layout specific. This property describes the relative weight that
+ should be given to the receiver when extra space is distributed
+ between different #spaceFill cells."
+
+ ^ self
+ valueOfProperty: #spaceFillWeight
+ ifAbsent: [1]!
Item was added:
+ ----- Method: Morph>>spaceFillWeight: (in category 'layout-properties') -----
+ spaceFillWeight: aNumber
+ "Layout specific. This property describes the relative weight that should be given to the receiver when extra space is distributed between different #spaceFill cells."
+ aNumber = 1
+ ifTrue:[self removeProperty: #spaceFillWeight]
+ ifFalse:[self setProperty: #spaceFillWeight toValue: aNumber].
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>specialNameInModel (in category 'naming') -----
+ specialNameInModel
+ "Return the name for this morph in the underlying model or nil."
+
+ "Not an easy problem. For now, take the first part of the mouseDownSelector symbol in my eventHandler (fillBrushMouseUp:morph: gives 'fillBrush'). 5/26/97 tk"
+
+ | hh |
+ (self isMorphicModel)
+ ifTrue: [^self slotName]
+ ifFalse:
+ [self eventHandler ifNotNil:
+ [self eventHandler mouseDownSelector ifNotNil:
+ [hh := self eventHandler mouseDownSelector indexOfSubCollection: 'Mouse'
+ startingAt: 1.
+ hh > 0
+ ifTrue: [^self eventHandler mouseDownSelector copyFrom: 1 to: hh - 1]].
+ self eventHandler mouseUpSelector ifNotNil:
+ [hh := self eventHandler mouseUpSelector indexOfSubCollection: 'Mouse'
+ startingAt: 1.
+ hh > 0 ifTrue: [^self eventHandler mouseUpSelector copyFrom: 1 to: hh - 1]]]].
+
+ " (self eventHandler mouseDownRecipient respondsTo: #nameFor:) ifTrue: [
+ ^ self eventHandler mouseDownRecipient nameFor: self]]]. "
+ "myModel := self findA: MorphicModel.
+ myModel ifNotNil: [^ myModel slotName]"
+ ^self world specialNameInModelFor: self!
Item was added:
+ ----- Method: Morph>>sqkPage (in category 'accessing') -----
+ sqkPage
+ ^ self valueOfProperty: #SqueakPage!
Item was added:
+ ----- Method: Morph>>standardPalette (in category 'initialization') -----
+ standardPalette
+ "Answer a standard palette forced by some level of enclosing presenter, or nil if none"
+ | pal aPresenter itsOwner |
+ (aPresenter := self presenter) ifNil: [^ nil].
+ ^ (pal := aPresenter ownStandardPalette)
+ ifNotNil: [pal]
+ ifNil: [(itsOwner := aPresenter associatedMorph owner)
+ ifNotNil:
+ [itsOwner standardPalette]
+ ifNil:
+ [nil]]!
Item was added:
+ ----- Method: Morph>>start (in category 'stepping and presenter') -----
+ start
+ "Start running my script. For ordinary morphs, this means start stepping."
+
+ self startStepping.
+ !
Item was added:
+ ----- Method: Morph>>startDrag: (in category 'event handling') -----
+ startDrag: evt
+ "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing."
+
+ self eventHandler ifNotNil:
+ [self eventHandler startDrag: evt fromMorph: self].!
Item was added:
+ ----- Method: Morph>>startDrag:with: (in category 'dropping/grabbing') -----
+ startDrag: anItem with: anObject
+ self currentHand attachMorph: anObject!
Item was added:
+ ----- Method: Morph>>startStepping (in category 'stepping and presenter') -----
+ startStepping
+ "Start getting sent the 'step' message."
+ self startStepping: #stepAt: at: Time millisecondClockValue arguments: nil stepTime: nil.!
Item was added:
+ ----- Method: Morph>>startStepping:at:arguments:stepTime: (in category 'stepping and presenter') -----
+ startStepping: aSelector at: scheduledTime arguments: args stepTime: stepTime
+ "Start stepping the receiver"
+ | w |
+ w := self world.
+ w ifNotNil: [
+ w startStepping: self at: scheduledTime selector: aSelector arguments: args stepTime: stepTime.
+ self changed].!
Item was added:
+ ----- Method: Morph>>startSteppingIn: (in category 'stepping and presenter') -----
+ startSteppingIn: aWorld
+ "Start getting sent the 'step' message in aWorld"
+
+ self step. "one to get started!!"
+ aWorld ifNotNil: [aWorld startStepping: self].
+ self changed!
Item was added:
+ ----- Method: Morph>>startSteppingSelector: (in category 'stepping and presenter') -----
+ startSteppingSelector: aSelector
+ "Start getting sent the 'step' message."
+ self startStepping: aSelector at: Time millisecondClockValue arguments: nil stepTime: nil.!
Item was added:
+ ----- Method: Morph>>startWiring (in category 'menu') -----
+ startWiring
+ Smalltalk
+ at: #NCAAConnectorMorph
+ ifPresent: [:connectorClass | connectorClass newCurvyArrow startWiringFrom: self] !
Item was added:
+ ----- Method: Morph>>step (in category 'stepping and presenter') -----
+ step
+ "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. The generic version dispatches control to the player, if any. The nasty circumlocation about owner's transformation is necessitated by the flexing problem that the player remains in the properties dictionary both of the flex and the real morph. In the current architecture, only the top renderer's pointer to the player should actually be honored for the purpose of firing."
+ !
Item was added:
+ ----- Method: Morph>>stepAt: (in category 'stepping and presenter') -----
+ stepAt: millisecondClockValue
+ "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message.
+ The millisecondClockValue parameter gives the value of the millisecond clock at the moment of dispatch.
+ Default is to dispatch to the parameterless step method for the morph, but this protocol makes it possible for some morphs to do differing things depending on the clock value"
+ self player ifNotNil:[:p| p stepAt: millisecondClockValue].
+ self step
+ !
Item was added:
+ ----- Method: Morph>>stepTime (in category 'testing') -----
+ stepTime
+ "Answer the desired time between steps in milliseconds. This default implementation requests that the 'step' method be called once every second."
+
+ ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [1000]!
Item was added:
+ ----- Method: Morph>>stickinessString (in category 'menus') -----
+ stickinessString
+ "Answer the string to be shown in a menu to represent the
+ stickiness status"
+ ^ (self isSticky
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ , 'resist being picked up' translated!
Item was added:
+ ----- Method: Morph>>sticky: (in category 'accessing') -----
+ sticky: aBoolean
+ "change the receiver's sticky property"
+ (extension isNil and: [aBoolean not]) ifTrue: [^ self].
+ self assureExtension sticky: aBoolean!
Item was added:
+ ----- Method: Morph>>stop (in category 'stepping and presenter') -----
+ stop
+ "Stop running my script. For ordinary morphs, this means stop stepping."
+
+ self stopStepping.
+ !
Item was added:
+ ----- Method: Morph>>stopStepping (in category 'stepping and presenter') -----
+ stopStepping
+ "Stop getting sent the 'step' message."
+
+ | w |
+ w := self world.
+ w ifNotNil: [w stopStepping: self].
+ !
Item was added:
+ ----- Method: Morph>>stopSteppingSelector: (in category 'stepping and presenter') -----
+ stopSteppingSelector: aSelector
+ "Stop getting sent the given message."
+ | w |
+ w := self world.
+ w ifNotNil: [w stopStepping: self selector: aSelector].
+ !
Item was added:
+ ----- Method: Morph>>stopSteppingSelfAndSubmorphs (in category 'stepping and presenter') -----
+ stopSteppingSelfAndSubmorphs
+ self allMorphsDo: [:m | m stopStepping]
+ !
Item was added:
+ ----- Method: Morph>>storeDataOn: (in category 'objects from disk') -----
+ storeDataOn: aDataStream
+ "Let all Morphs be written out. All owners are weak references. They only go out if the owner is in the tree being written."
+ | cntInstVars cntIndexedVars ti localInstVars |
+
+ "block my owner unless he is written out by someone else"
+ cntInstVars := self class instSize.
+ cntIndexedVars := self basicSize.
+ localInstVars := Morph instVarNames.
+ ti := 2.
+ ((localInstVars at: ti) = 'owner') & (Morph superclass == Object) ifFalse:
+ [self error: 'this method is out of date'].
+ aDataStream
+ beginInstance: self class
+ size: cntInstVars + cntIndexedVars.
+ 1 to: ti-1 do:
+ [:i | aDataStream nextPut: (self instVarAt: i)].
+ aDataStream nextPutWeak: owner. "owner only written if in our tree"
+ ti+1 to: cntInstVars do:
+ [:i | aDataStream nextPut: (self instVarAt: i)].
+ 1 to: cntIndexedVars do:
+ [:i | aDataStream nextPut: (self basicAt: i)]!
Item was added:
+ ----- Method: Morph>>structureString (in category 'printing') -----
+ structureString
+ "Return a string that showing this morph and all its submorphs in an indented list that reflects its structure."
+
+ | s |
+ s := WriteStream on: (String new: 1000).
+ self printStructureOn: s indent: 0.
+ ^ s contents
+ !
Item was added:
+ ----- Method: Morph>>subclassMorph (in category 'meta-actions') -----
+ subclassMorph
+ "Create a new subclass of this morph's class and make this morph be an instance of it."
+
+ | oldClass newClassName newClass |
+ oldClass := self class.
+ newClassName := UIManager default
+ request: 'Please give this new class a name'
+ initialAnswer: oldClass name.
+ newClassName = '' ifTrue: [^ self].
+ (Smalltalk includesKey: newClassName)
+ ifTrue: [^ self inform: 'Sorry, there is already a class of that name'].
+
+ newClass := oldClass subclass: newClassName asSymbol
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: oldClass category asString.
+ self becomeForward: (self as: newClass)!
Item was added:
+ ----- Method: Morph>>submorphAfter (in category 'submorphs-accessing') -----
+ submorphAfter
+ "Return the submorph after (behind) me, or nil"
+ | ii |
+ owner ifNil: [^ nil].
+ ^ (ii := owner submorphIndexOf: self) = owner submorphs size
+ ifTrue: [nil]
+ ifFalse: [owner submorphs at: ii+1].
+
+ !
Item was added:
+ ----- Method: Morph>>submorphBefore (in category 'submorphs-accessing') -----
+ submorphBefore
+ "Return the submorph after (behind) me, or nil"
+ | ii |
+ owner ifNil: [^ nil].
+ ^ (ii := owner submorphIndexOf: self) = 1
+ ifTrue: [nil]
+ ifFalse: [owner submorphs at: ii-1].
+
+ !
Item was added:
+ ----- Method: Morph>>submorphBounds (in category 'layout') -----
+ submorphBounds
+ "Private. Compute the actual full bounds of the receiver"
+ | box |
+ submorphs do: [:m | | subBox |
+ (m visible) ifTrue: [
+ subBox := m fullBounds.
+ box
+ ifNil:[box := subBox copy]
+ ifNotNil:[box := box quickMerge: subBox]]].
+ box ifNil:[^self bounds]. "e.g., having submorphs but not visible"
+ ^ box origin asIntegerPoint corner: box corner asIntegerPoint
+ !
Item was added:
+ ----- Method: Morph>>submorphCount (in category 'submorphs-accessing') -----
+ submorphCount
+
+ ^ submorphs size!
Item was added:
+ ----- Method: Morph>>submorphIndexOf: (in category 'submorphs-add/remove') -----
+ submorphIndexOf: aMorph
+ "Assuming aMorph to be one of my submorphs, answer where it occurs in my submorph list"
+
+ ^ submorphs indexOf: aMorph ifAbsent: [nil]!
Item was added:
+ ----- Method: Morph>>submorphNamed: (in category 'submorphs-accessing') -----
+ submorphNamed: aName
+ ^ self submorphNamed: aName ifNone: [nil]!
Item was added:
+ ----- Method: Morph>>submorphNamed:ifNone: (in category 'submorphs-accessing') -----
+ submorphNamed: aName ifNone: aBlock
+ "Find the first submorph with this name, or a button with an action selector of that name"
+
+
+ self submorphs do: [:p | p knownName = aName ifTrue: [^p]].
+ self submorphs do:
+ [:button | | sub args |
+ (button respondsTo: #actionSelector)
+ ifTrue: [button actionSelector == aName ifTrue: [^button]].
+ ((button respondsTo: #arguments) and: [(args := button arguments) notNil])
+ ifTrue: [(args at: 2 ifAbsent: [nil]) == aName ifTrue: [^button]].
+ (button isAlignmentMorph)
+ ifTrue: [(sub := button submorphNamed: aName ifNone: [nil]) ifNotNil: [^sub]]].
+ ^aBlock value!
Item was added:
+ ----- Method: Morph>>submorphOfClass: (in category 'submorphs-accessing') -----
+ submorphOfClass: aClass
+
+ ^self findA: aClass!
Item was added:
+ ----- Method: Morph>>submorphThat:ifNone: (in category 'submorphs-accessing') -----
+ submorphThat: block1 ifNone: block2
+
+ ^submorphs detect: block1 ifNone: block2
+ !
Item was added:
+ ----- Method: Morph>>submorphWithProperty: (in category 'submorphs-accessing') -----
+ submorphWithProperty: aSymbol
+ ^ submorphs detect: [:aMorph | aMorph hasProperty: aSymbol] ifNone: [nil]!
Item was added:
+ ----- Method: Morph>>submorphs (in category 'submorphs-accessing') -----
+ submorphs
+ "This method returns my actual submorphs collection. Modifying the collection directly could be dangerous; make a copy if you need to alter it."
+ ^ submorphs !
Item was added:
+ ----- Method: Morph>>submorphsBehind:do: (in category 'submorphs-accessing') -----
+ submorphsBehind: aMorph do: aBlock
+ | behind |
+ behind := false.
+ submorphs do:
+ [:m | m == aMorph ifTrue: [behind := true]
+ ifFalse: [behind ifTrue: [aBlock value: m]]].
+ !
Item was added:
+ ----- Method: Morph>>submorphsDo: (in category 'submorphs-accessing') -----
+ submorphsDo: aBlock
+ submorphs do: aBlock!
Item was added:
+ ----- Method: Morph>>submorphsInFrontOf:do: (in category 'submorphs-accessing') -----
+ submorphsInFrontOf: aMorph do: aBlock
+ | behind |
+ behind := false.
+ submorphs do:
+ [:m | m == aMorph ifTrue: [behind := true]
+ ifFalse: [behind ifFalse: [aBlock value: m]]].
+ !
Item was added:
+ ----- Method: Morph>>submorphsReverseDo: (in category 'submorphs-accessing') -----
+ submorphsReverseDo: aBlock
+
+ submorphs reverseDo: aBlock.!
Item was added:
+ ----- Method: Morph>>submorphsSatisfying: (in category 'submorphs-accessing') -----
+ submorphsSatisfying: aBlock
+ ^ submorphs select: [:m | (aBlock value: m) == true]!
Item was added:
+ ----- Method: Morph>>suspendEventHandler (in category 'event handling') -----
+ suspendEventHandler
+ self eventHandler ifNotNil:
+ [self setProperty: #suspendedEventHandler toValue: self eventHandler.
+ self eventHandler: nil].
+ submorphs do: [:m | m suspendEventHandler]. "All those rectangles"!
Item was added:
+ ----- Method: Morph>>tabAmongFields (in category 'event handling') -----
+ tabAmongFields
+ ^ Preferences tabAmongFields
+ or: [self hasProperty: #tabAmongFields] !
Item was added:
+ ----- Method: Morph>>target: (in category 'accessing-backstop') -----
+ target: aMorph
+ "Morphs with targets will override. This backstop does nothing."
+ "This is here because targeting meta-actions are taken at morph level.
+ Do not remove."!
Item was added:
+ ----- Method: Morph>>targetFromMenu: (in category 'meta-actions') -----
+ targetFromMenu: aMenu
+ "Some other morph become target of the receiver"
+ | newTarget |
+
+ newTarget := aMenu startUpWithCaption: self externalName , ' targets...'.
+ newTarget
+ ifNil: [^ self].
+ self target: newTarget!
Item was added:
+ ----- Method: Morph>>targetWith: (in category 'meta-actions') -----
+ targetWith: evt
+ "Some other morph become target of the receiver"
+ | morphs newTarget |
+ morphs := self potentialTargets.
+ newTarget := UIManager default
+ chooseFrom: (morphs collect: [:m | m knownName ifNil:[m class name asString]])
+ values: morphs
+ title: self externalName, ' targets...'.
+ newTarget ifNil:[^self].
+ self target: newTarget.!
Item was added:
+ ----- Method: Morph>>tempCommand (in category 'debug and other') -----
+ tempCommand
+ "Generic backstop. If you care to, you can comment out what's below here, and substitute your own code, though the intention of design of the feature is that you leave this method as it is, and instead reimplement tempCommand in the class of whatever individual morph you care to. In any case, once you have your own #tempCommand in place, you will then be able to invoke it from the standard debugging menus."
+
+ self inform: 'Before calling tempCommand, you
+ should first give it a definition. To
+ do this, choose "define tempCommand"
+ from the debug menu.' translated!
Item was added:
+ ----- Method: Morph>>textAnchorType (in category 'text-anchor') -----
+ textAnchorType
+ ^self valueOfProperty: #textAnchorType ifAbsent:[#document]!
Item was added:
+ ----- Method: Morph>>textAnchorType: (in category 'text-anchor') -----
+ textAnchorType: aSymbol
+ aSymbol == #document
+ ifTrue:[^self removeProperty: #textAnchorType]
+ ifFalse:[^self setProperty: #textAnchorType toValue: aSymbol].!
Item was added:
+ ----- Method: Morph>>textToPaste (in category 'printing') -----
+ textToPaste
+ "If the receiver has text to offer pasting, answer it, else answer nil"
+
+ ^ nil!
Item was added:
+ ----- Method: Morph>>textureParameters (in category 'e-toy support') -----
+ textureParameters
+ "Answer a triplet giving the preferred grid size, background color, and line color. The choices here are as suggested by Alan, 9/13/97"
+
+ ^ Array with: 16 with: Color lightYellow with: Color lightGreen lighter lighter!
Item was added:
+ ----- Method: Morph>>toggleCornerRounding (in category 'rounding') -----
+ toggleCornerRounding
+ self cornerStyle == #rounded
+ ifTrue: [self cornerStyle: #square]
+ ifFalse: [self cornerStyle: #rounded].
+ self changed!
Item was added:
+ ----- Method: Morph>>toggleDragNDrop (in category 'dropping/grabbing') -----
+ toggleDragNDrop
+ "Toggle this morph's ability to add and remove morphs via drag-n-drop."
+
+ self enableDragNDrop: self dragNDropEnabled not.
+ !
Item was added:
+ ----- Method: Morph>>toggleDropShadow (in category 'drop shadows') -----
+ toggleDropShadow
+ self hasDropShadow
+ ifTrue:[self removeDropShadow]
+ ifFalse:[self addDropShadow].!
Item was added:
+ ----- Method: Morph>>toggleLocked (in category 'accessing') -----
+ toggleLocked
+
+ self lock: self isLocked not!
Item was added:
+ ----- Method: Morph>>toggleResistsRemoval (in category 'accessing') -----
+ toggleResistsRemoval
+ "Toggle the resistsRemoval property"
+
+ self resistsRemoval
+ ifTrue:
+ [self removeProperty: #resistsRemoval]
+ ifFalse:
+ [self setProperty: #resistsRemoval toValue: true]!
Item was added:
+ ----- Method: Morph>>toggleStickiness (in category 'accessing') -----
+ toggleStickiness
+ "togle the receiver's Stickiness"
+ extension ifNil: [^ self beSticky].
+ extension sticky: extension sticky not!
Item was added:
+ ----- Method: Morph>>top (in category 'geometry') -----
+ top
+ " Return the y-coordinate of my top side "
+
+ ^ bounds top!
Item was added:
+ ----- Method: Morph>>top: (in category 'geometry') -----
+ top: aNumber
+ " Move me so that my top is at the y-coordinate aNumber. My extent (width & height) are unchanged "
+
+ self position: (bounds left @ aNumber)!
Item was added:
+ ----- Method: Morph>>topCenter (in category 'geometry') -----
+ topCenter
+
+ ^ bounds topCenter!
Item was added:
+ ----- Method: Morph>>topLeft (in category 'geometry') -----
+ topLeft
+
+ ^ bounds topLeft!
Item was added:
+ ----- Method: Morph>>topLeft: (in category 'geometry') -----
+ topLeft: aPoint
+ " Move me so that my top left corner is at aPoint. My extent (width & height) are unchanged "
+
+ self position: aPoint
+ !
Item was added:
+ ----- Method: Morph>>topPasteUp (in category 'structure') -----
+ topPasteUp
+ "If the receiver is in a world, return that; otherwise return the outermost pasteup morph"
+ ^ self outermostMorphThat: [:m | m isKindOf: PasteUpMorph]!
Item was added:
+ ----- Method: Morph>>topRendererOrSelf (in category 'structure') -----
+ topRendererOrSelf
+ "Answer the topmost renderer for this morph, or this morph itself if it has no renderer. See the comment in Morph>isRenderer."
+
+ | top topsOwner |
+ owner ifNil: [^self].
+ self isWorldMorph ifTrue: [^self]. "ignore scaling of this world"
+ top := self.
+ topsOwner := top owner.
+ [topsOwner notNil and: [topsOwner isRenderer]] whileTrue:
+ [top := topsOwner.
+ topsOwner := top owner].
+ ^top!
Item was added:
+ ----- Method: Morph>>topRight (in category 'geometry') -----
+ topRight
+
+ ^ bounds topRight!
Item was added:
+ ----- Method: Morph>>topRight: (in category 'geometry') -----
+ topRight: aPoint
+ " Move me so that my top right corner is at aPoint. My extent (width & height) are unchanged "
+
+ self position: ((aPoint x - bounds width) @ (aPoint y))
+ !
Item was added:
+ ----- Method: Morph>>transferHalo:from: (in category 'halos and balloon help') -----
+ transferHalo: event from: formerHaloOwner
+ "Progressively transfer the halo to the next likely recipient"
+ | localEvt w target |
+
+ self flag: #workAround. "For halo's distinction between 'target' and 'innerTarget' we need to bypass any renderers."
+ (formerHaloOwner == self and:[self isRenderer and:[self wantsHaloFromClick not]]) ifTrue:[
+ event shiftPressed ifTrue:[
+ target := owner.
+ localEvt := event transformedBy: (self transformedFrom: owner).
+ ] ifFalse:[
+ target := self renderedMorph.
+ localEvt := event transformedBy: (target transformedFrom: self).
+ ].
+ ^target transferHalo: localEvt from: target].
+
+ " formerHaloOwner == self ifTrue:[^ self removeHalo]."
+
+ "Never transfer halo to top-most world"
+ (self isWorldMorph and:[owner isNil]) ifFalse:[
+ (self wantsHaloFromClick and:[formerHaloOwner ~~ self])
+ ifTrue:[^self addHalo: event from: formerHaloOwner]].
+
+ event shiftPressed ifTrue:[
+ "Pass it outwards"
+ owner ifNotNil:[^owner transferHalo: event from: formerHaloOwner].
+ "We're at the top level; throw the event back in to find recipient"
+ formerHaloOwner removeHalo.
+ ^self processEvent: event copy resetHandlerFields.
+ ].
+ self submorphsDo:[:m|
+ localEvt := event transformedBy: (m transformedFrom: self).
+ (m fullContainsPoint: localEvt position)
+ ifTrue:[^m transferHalo: event from: formerHaloOwner].
+ ].
+ "We're at the bottom most level; throw the event back up to the root to find recipient"
+ formerHaloOwner removeHalo.
+
+ Preferences maintainHalos ifFalse:[
+ (w := self world) ifNil: [ ^self ].
+ localEvt := event transformedBy: (self transformedFrom: w) inverseTransformation.
+ ^w processEvent: localEvt resetHandlerFields.
+ ].
+ !
Item was added:
+ ----- Method: Morph>>transferStateToRenderer: (in category 'menus') -----
+ transferStateToRenderer: aRenderer
+ "Transfer knownName, actorState, visible, and player info over to aRenderer, which is being imposed above me as a transformation shell"
+
+ | current |
+ (current := self actorStateOrNil) ifNotNil:
+ [aRenderer actorState: current.
+ self actorState: nil].
+
+ (current := self knownName) ifNotNil:
+ [aRenderer setNameTo: current.
+ self setNameTo: nil].
+
+ (current := self player) ifNotNil:
+ [aRenderer player: current.
+ self player rawCostume: aRenderer.
+ "NB player is redundantly pointed to in the extension of both the renderer and the rendee; this is regrettable but many years ago occasionally people tried to make that clean but always ran into problems iirc"
+ "self player: nil"].
+
+ aRenderer simplySetVisible: self visible
+
+
+
+
+
+ !
Item was added:
+ ----- Method: Morph>>transformFrom: (in category 'event handling') -----
+ transformFrom: uberMorph
+ "Return a transform to be used to map coordinates in a morph above me into my childrens coordinates, or vice-versa. This is used to support scrolling, scaling, and/or rotation. This default implementation just returns my owner's transform or the identity transform if my owner is nil.
+ Note: This method cannot be used to map into the receiver's coordinate system!!"
+
+ (self == uberMorph or: [owner isNil]) ifTrue: [^IdentityTransform new].
+ ^owner transformFrom: uberMorph!
Item was added:
+ ----- Method: Morph>>transformFromOutermostWorld (in category 'event handling') -----
+ transformFromOutermostWorld
+ "Return a transform to map world coordinates into my local coordinates"
+
+ "self isWorldMorph ifTrue: [^ MorphicTransform identity]."
+ ^ self transformFrom: self outermostWorldMorph!
Item was added:
+ ----- Method: Morph>>transformFromWorld (in category 'event handling') -----
+ transformFromWorld
+ "Return a transform to map world coordinates into my local coordinates"
+
+ ^ self transformFrom: nil!
Item was added:
+ ----- Method: Morph>>transformedBy: (in category 'geometry') -----
+ transformedBy: aTransform
+ aTransform isIdentity ifTrue:[^self].
+ aTransform isPureTranslation ifTrue:[
+ ^self position: (aTransform localPointToGlobal: self position).
+ ].
+ ^self addFlexShell transformedBy: aTransform!
Item was added:
+ ----- Method: Morph>>transformedFrom: (in category 'events-processing') -----
+ transformedFrom: uberMorph
+ "Return a transform to map coordinates of uberMorph, a morph above me in my owner chain, into the coordinates of MYSELF not any of my children."
+ self flag: #arNote. "rename this method"
+ owner ifNil:[^IdentityTransform new].
+ ^ (owner transformFrom: uberMorph)!
Item was added:
+ ----- Method: Morph>>transportedMorph (in category 'dropping/grabbing') -----
+ transportedMorph
+ ^self!
Item was added:
+ ----- Method: Morph>>triggerActionFromPianoRoll (in category '*Morphic-Sound-piano rolls') -----
+ triggerActionFromPianoRoll
+
+ | evt |
+ "a hack to allow for abitrary morphs to be dropped into piano roll"
+ self world ifNil: [^self].
+ evt := MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand.
+ self programmedMouseUp: evt for: self.
+
+ !
Item was added:
+ ----- Method: Morph>>tryToRenameTo: (in category 'naming') -----
+ tryToRenameTo: aName
+ "A new name has been submited; make sure it's appropriate, and react accordingly. This circumlocution provides the hook by which the simple renaming of a field can result in a change to variable names in a stack, etc. There are some problems to worry about here."
+
+ self renameTo: aName.!
Item was added:
+ ----- Method: Morph>>unHighlight (in category 'accessing') -----
+ unHighlight
+ self color: self regularColor!
Item was added:
+ ----- Method: Morph>>uncollapseSketch (in category 'menus') -----
+ uncollapseSketch
+
+ | uncollapsedVersion w whomToDelete |
+
+ (w := self world) ifNil: [^self].
+ uncollapsedVersion := self valueOfProperty: #uncollapsedMorph.
+ uncollapsedVersion ifNil: [^self].
+ whomToDelete := self valueOfProperty: #collapsedMorphCarrier.
+ uncollapsedVersion setProperty: #collapsedPosition toValue: whomToDelete position.
+
+ whomToDelete delete.
+ w addMorphFront: uncollapsedVersion.
+
+ !
Item was added:
+ ----- Method: Morph>>undoGrabCommand (in category 'dropping/grabbing') -----
+ undoGrabCommand
+ "Return an undo command for grabbing the receiver"
+
+ | cmd |
+ owner ifNil:
+ [^ nil]. "no owner - no undo"
+ ^ (cmd := Command new)
+ cmdWording: 'move ' translated, self nameForUndoWording;
+ undoTarget: self
+ selector: #undoMove:redo:owner:bounds:predecessor:
+ arguments: {cmd. false. owner. self bounds. (owner morphPreceding: self)};
+ yourself!
Item was added:
+ ----- Method: Morph>>undoMove:redo:owner:bounds:predecessor: (in category 'undo') -----
+ undoMove: cmd redo: redo owner: formerOwner bounds: formerBounds predecessor: formerPredecessor
+ "Handle undo and redo of move commands in morphic"
+
+ self owner ifNil: [^Beeper beep].
+ redo
+ ifFalse:
+ ["undo sets up the redo state first"
+
+ cmd
+ redoTarget: self
+ selector: #undoMove:redo:owner:bounds:predecessor:
+ arguments: {
+ cmd.
+ true.
+ owner.
+ bounds.
+ owner morphPreceding: self}].
+ formerOwner ifNotNil:
+ [formerPredecessor ifNil: [formerOwner addMorphFront: self]
+ ifNotNil: [formerOwner addMorph: self after: formerPredecessor]].
+ self bounds: formerBounds.
+ (self isSystemWindow) ifTrue: [self activate]!
Item was added:
+ ----- Method: Morph>>unlock (in category 'accessing') -----
+ unlock
+ self lock: false!
Item was added:
+ ----- Method: Morph>>unlockContents (in category 'accessing') -----
+ unlockContents
+ self submorphsDo:
+ [:m | m unlock]!
Item was added:
+ ----- Method: Morph>>unlockOneSubpart (in category 'e-toy support') -----
+ unlockOneSubpart
+ | unlockables reply |
+ unlockables := self submorphs select:
+ [:m | m isLocked].
+ unlockables size <= 1 ifTrue: [^ self unlockContents].
+ reply := UIManager default
+ chooseFrom: (unlockables collect: [:m | m externalName])
+ values: unlockables
+ title: 'Who should be be unlocked?' translated.
+ reply isNil ifTrue: [^ self].
+ reply unlock!
Item was added:
+ ----- Method: Morph>>updateAllFromResources (in category 'fileIn/out') -----
+ updateAllFromResources
+
+ self allMorphsDo: [:m | m updateFromResource]!
Item was added:
+ ----- Method: Morph>>updateAllScriptingElements (in category 'naming') -----
+ updateAllScriptingElements
+ "A sledge-hammer sweep from the world down to make sure that all live scripting elements are up to date. Presently in eclipse, not sent at the moment."
+
+ | aPasteUp |
+ (aPasteUp := self topPasteUp) ifNotNil:
+ [aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]]!
Item was added:
+ ----- Method: Morph>>updateCachedThumbnail (in category 'e-toy support') -----
+ updateCachedThumbnail
+ "If I have a cached thumbnail, then update it. Copied up from Dan's original version in PasteUpMorph so it can be used by all morphs."
+ | cachedThumbnail |
+
+ (cachedThumbnail := self valueOfProperty: #cachedThumbnail) ifNotNil:
+ [(cachedThumbnail respondsTo: #computeThumbnail)
+ ifTrue: [cachedThumbnail computeThumbnail]
+ ifFalse: [self removeProperty: #computeThumbnail]].
+ "Test and removal are because the thumbnail is being replaced by another Morph. We don't know why. Need to fix that at the source."!
Item was added:
+ ----- Method: Morph>>updateDropShadowCache (in category 'drawing') -----
+ updateDropShadowCache
+
+ | shadowBounds offset form canvas drawBlock localBounds mask maskCanvas |
+ shadowBounds := self shadowOffset isRectangle
+ ifTrue: [0 at 0 corner: (self bounds outsetBy: self shadowOffset) extent]
+ ifFalse: [0 at 0 corner: self extent + self shadowOffset abs].
+ offset := self shadowOffset isRectangle
+ ifTrue: [0 at 0]
+ ifFalse: [self shadowOffset max: 0 at 0].
+ localBounds := self shadowOffset isRectangle
+ ifTrue: [self shadowOffset topLeft extent: self extent]
+ ifFalse: [(self shadowOffset negated max: 0 at 0) extent: self extent].
+
+ form := Form extent: shadowBounds extent depth: Display depth.
+ canvas := form getCanvas.
+
+ drawBlock := self useSoftDropShadow
+ ifFalse: [
+ [:c | self wantsRoundedCorners
+ ifTrue: [c fillRoundRect: localBounds radius: self class preferredCornerRadius fillStyle: self shadowColor]
+ ifFalse: [c fillRectangle: localBounds fillStyle: self shadowColor]]]
+ ifTrue: [
+ [:c | self wantsRoundedCorners
+ ifTrue: [0 to: 9 do: [:i |
+ c
+ fillRoundRect: (shadowBounds insetBy: i)
+ radius: (self class preferredCornerRadius max: 20) -i
+ fillStyle: (self shadowColor alpha: self shadowColor alpha * (i+1))]]
+ ifFalse: [0 to: 9 do: [:i |
+ c
+ fillRoundRect: (shadowBounds insetBy: i) radius: 20-i
+ fillStyle: (self shadowColor alpha: self shadowColor alpha * (i+1))]]]].
+
+ canvas
+ translateBy: offset
+ during: [ :shadowCanvas | drawBlock value: shadowCanvas].
+
+ "Support transparent morph colors without having the shadow to shine through.."
+ mask := Form extent: shadowBounds extent depth: Display depth.
+ maskCanvas := mask getCanvas.
+ self wantsRoundedCorners
+ ifTrue: [maskCanvas fillRoundRect: (localBounds insetBy: self borderWidth) radius: self class preferredCornerRadius fillStyle: Color black]
+ ifFalse: [maskCanvas fillRectangle: (localBounds insetBy: self borderWidth) fillStyle: Color black].
+ mask
+ displayOn: form
+ at: 0 at 0
+ rule: Form erase.
+
+ self setProperty: #dropShadow toValue: form.!
Item was added:
+ ----- Method: Morph>>updateFromResource (in category 'fileIn/out') -----
+ updateFromResource
+ | pathName newMorph f |
+ (pathName := self valueOfProperty: #resourceFilePath) ifNil: [^self].
+ (pathName asLowercase endsWith: '.morph')
+ ifTrue:
+ [newMorph := (FileStream readOnlyFileNamed: pathName) fileInObjectAndCode.
+ (newMorph isMorph)
+ ifFalse: [^self error: 'Resource not a single morph']]
+ ifFalse:
+ [f := Form fromFileNamed: pathName.
+ f ifNil: [^self error: 'unrecognized image file format'].
+ newMorph := World drawingClass withForm: f].
+ newMorph setProperty: #resourceFilePath toValue: pathName.
+ self owner replaceSubmorph: self by: newMorph!
Item was added:
+ ----- Method: Morph>>updateReferencesUsing: (in category 'copying') -----
+ updateReferencesUsing: aDictionary
+ "Update intra-morph references within a composite morph that
+ has been copied. For example, if a button refers to morph X in
+ the orginal
+ composite then the copy of that button in the new composite
+ should refer to
+ the copy of X in new composite, not the original X. This default
+ implementation updates the contents of any morph-bearing slot.
+ It may be
+ overridden to avoid this behavior if so desired."
+ | old |
+ Morph instSize + 1
+ to: self class instSize
+ do: [:i |
+ old := self instVarAt: i.
+ old isMorph
+ ifTrue: [self
+ instVarAt: i
+ put: (aDictionary
+ at: old
+ ifAbsent: [old])]].
+ extension ifNotNil: [extension updateReferencesUsing: aDictionary]!
Item was added:
+ ----- Method: Morph>>updateThumbnailUrl (in category 'thumbnail') -----
+ updateThumbnailUrl
+ "If I have a cached thumbnail, then update it's urls."
+ | cachedThumbnail |
+
+ (cachedThumbnail := self valueOfProperty: #cachedThumbnail) ifNotNil:
+ [(cachedThumbnail respondsTo: #computeThumbnail)
+ ifTrue: [cachedThumbnail pageMorph: self url inBook: owner url]
+ ifFalse: [self removeProperty: #computeThumbnail]].
+ "Test and removal are because the thumbnail is being replaced
+ by another Morph. We don't know why. Need to fix that at
+ the source."!
Item was added:
+ ----- Method: Morph>>updateThumbnailUrlInBook: (in category 'thumbnail') -----
+ updateThumbnailUrlInBook: bookUrl
+ "If I have a cached thumbnail, then update it's urls."
+ | cachedThumbnail |
+
+ (cachedThumbnail := self valueOfProperty: #cachedThumbnail) ifNotNil:
+ [(cachedThumbnail respondsTo: #computeThumbnail)
+ ifTrue: [cachedThumbnail pageMorph: self url inBook: bookUrl]
+ ifFalse: [self removeProperty: #computeThumbnail]].
+ "Test and removal are because the thumbnail is being replaced
+ by another Morph. We don't know why. Need to fix that at
+ the source."!
Item was added:
+ ----- Method: Morph>>updateableActionMap (in category 'events-accessing') -----
+ updateableActionMap
+ "Answer an updateable action map, saving it in my #actionMap property"
+
+ | actionMap |
+ actionMap := self valueOfProperty: #actionMap.
+ actionMap ifNil:
+ [actionMap := self createActionMap.
+ self setProperty: #actionMap toValue: actionMap].
+ ^ actionMap!
Item was added:
+ ----- Method: Morph>>url (in category 'accessing') -----
+ url
+ "If I have been assigned a url, return it. For PasteUpMorphs mostly."
+ | sq |
+ (sq := self sqkPage) ifNotNil: [^ sq url].
+ ^ self valueOfProperty: #url
+ !
Item was added:
+ ----- Method: Morph>>usableSiblingInstance (in category 'copying') -----
+ usableSiblingInstance
+ "Return another similar morph whose Player is of the same class as mine.
+ Do not open it in the world."
+
+ | aName usedNames newPlayer newMorph topRenderer |
+ (topRenderer := self topRendererOrSelf) == self
+ ifFalse: [^topRenderer usableSiblingInstance].
+ self assuredPlayer assureUniClass.
+ newMorph := self veryDeepCopySibling.
+ newPlayer := newMorph player.
+ newPlayer resetCostumeList.
+ (aName := self knownName) isNil
+ ifTrue: [self player notNil ifTrue: [aName := newMorph innocuousName]].
+ "Force a difference here"
+ aName notNil
+ ifTrue:
+ [usedNames := (self world ifNil: [OrderedCollection new]
+ ifNotNil: [self world allKnownNames]) copyWith: aName.
+ newMorph setNameTo: (Utilities keyLike: aName
+ satisfying: [:f | (usedNames includes: f) not])].
+ newMorph privateOwner: nil.
+ newPlayer assureEventHandlerRepresentsStatus.
+ self presenter flushPlayerListCache.
+ ^newMorph!
Item was added:
+ ----- Method: Morph>>useBitmapFill (in category 'visual properties') -----
+ useBitmapFill
+ "Make receiver use a solid fill style (e.g., a simple color)"
+ | fill |
+ self fillStyle isBitmapFill ifTrue:[^self]. "Already done"
+ fill := BitmapFillStyle fromForm: self defaultBitmapFillForm.
+ "Note: Must fix the origin due to global coordinates"
+ fill origin: self bounds origin.
+ self fillStyle: fill.!
Item was added:
+ ----- Method: Morph>>useDefaultFill (in category 'visual properties') -----
+ useDefaultFill
+ "Make receiver use a solid fill style (e.g., a simple color)"
+ self fillStyle: self defaultColor.!
Item was added:
+ ----- Method: Morph>>useGradientFill (in category 'visual properties') -----
+ useGradientFill
+ "Make receiver use a solid fill style (e.g., a simple color)"
+ | fill color1 color2 |
+ self fillStyle isGradientFill ifTrue:[^self]. "Already done"
+ color1 := self color asColor.
+ color2 := color1 negated.
+ fill := GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
+ fill origin: self topLeft.
+ fill direction: 0 @ self bounds extent y.
+ fill normal: self bounds extent x @ 0.
+ fill radial: false.
+ self fillStyle: fill!
Item was added:
+ ----- Method: Morph>>useSoftDropShadow (in category 'drop shadows') -----
+ useSoftDropShadow
+
+ ^ self
+ valueOfProperty: #useSoftDropShadow
+ ifAbsent: [self class useSoftDropShadow]!
Item was added:
+ ----- Method: Morph>>useSoftDropShadow: (in category 'drop shadows') -----
+ useSoftDropShadow: aBooleanOrNil
+
+ aBooleanOrNil
+ ifNil: [self removeProperty: #useSoftDropShadow]
+ ifNotNil: [self setProperty: #useSoftDropShadow toValue: aBooleanOrNil].!
Item was added:
+ ----- Method: Morph>>useSolidFill (in category 'visual properties') -----
+ useSolidFill
+ "Make receiver use a solid fill style (e.g., a simple color)"
+ self fillStyle isSolidFill ifTrue:[^self]. "Already done"
+ self fillStyle: self fillStyle asColor. "Try minimizing changes"!
Item was added:
+ ----- Method: Morph>>userSelectedColor: (in category 'change reporting') -----
+ userSelectedColor: aColor
+ "The user, via the UI, chose aColor to be the color for the receiver; set it, and tell my owner in case he wishes to react"
+ self color: aColor.
+ self world ifNotNil: [owner colorChangedForSubmorph: self]!
Item was added:
+ ----- Method: Morph>>userString (in category 'accessing') -----
+ userString
+ "Do I have a text string to be searched on?"
+
+ ^ nil!
Item was added:
+ ----- Method: Morph>>vResizeToFit: (in category 'layout-properties') -----
+ vResizeToFit: aBoolean
+ aBoolean ifTrue:[
+ self vResizing: #shrinkWrap.
+ ] ifFalse:[
+ self vResizing: #rigid.
+ ].!
Item was added:
+ ----- Method: Morph>>vResizing (in category 'layout-properties') -----
+ vResizing
+ "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
+ #rigid - do not resize the receiver
+ #spaceFill - resize to fill owner's available space
+ #shrinkWrap - resize to fit children
+ "
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#rigid] ifNotNil:[props vResizing].!
Item was added:
+ ----- Method: Morph>>vResizing: (in category 'layout-properties') -----
+ vResizing: aSymbol
+ "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
+ #rigid - do not resize the receiver
+ #spaceFill - resize to fill owner's available space
+ #shrinkWrap - resize to fit children
+ "
+ self assureLayoutProperties vResizing: aSymbol.
+ self layoutChanged.
+ !
Item was added:
+ ----- Method: Morph>>vResizingString: (in category 'layout-properties') -----
+ vResizingString: aSymbol
+ ^self layoutMenuPropertyString: aSymbol from: self vResizing!
Item was added:
+ ----- Method: Morph>>valueOfProperty: (in category 'accessing - properties') -----
+ valueOfProperty: aSymbol
+ "answer the value of the receiver's property named aSymbol"
+ ^ extension ifNotNil: [extension valueOfProperty: aSymbol]!
Item was added:
+ ----- Method: Morph>>valueOfProperty:ifAbsent: (in category 'accessing - properties') -----
+ valueOfProperty: aSymbol ifAbsent: aBlock
+ "if the receiver possesses a property of the given name, answer
+ its value. If not then evaluate aBlock and answer the result of
+ this block evaluation"
+
+ extension ifNil: [ ^aBlock value ].
+ ^extension valueOfProperty: aSymbol ifAbsent: aBlock!
Item was added:
+ ----- Method: Morph>>valueOfProperty:ifAbsentPut: (in category 'accessing - properties') -----
+ valueOfProperty: aSymbol ifAbsentPut: aBlock
+ "If the receiver possesses a property of the given name, answer
+ its value. If not, then create a property of the given name, give
+ it the value obtained by evaluating aBlock, then answer that
+ value"
+ ^ self assureExtension valueOfProperty: aSymbol ifAbsentPut: aBlock!
Item was added:
+ ----- Method: Morph>>valueOfProperty:ifPresentDo: (in category 'accessing - properties') -----
+ valueOfProperty: aSymbol ifPresentDo: aBlock
+ "If the receiver has a property of the given name, evaluate
+ aBlock on behalf of the value of that property"
+ extension ifNil: [^ self].
+ ^ aBlock value: (extension valueOfProperty: aSymbol ifAbsent: [^ self])!
Item was added:
+ ----- Method: Morph>>vanishAfterSlidingTo:event: (in category 'dropping/grabbing') -----
+ vanishAfterSlidingTo: aPosition event: evt
+
+ | aForm aWorld startPoint endPoint |
+ aForm := self imageForm offset: 0 at 0.
+ aWorld := self world.
+ startPoint := evt hand fullBounds origin.
+ self delete.
+ aWorld displayWorld.
+ endPoint := aPosition.
+ aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15.
+ SoundService soundEnabled ifTrue: [TrashCanMorph playDeleteSound].
+ !
Item was added:
+ ----- Method: Morph>>veryDeepCopyWith: (in category 'copying') -----
+ veryDeepCopyWith: deepCopier
+ "Copy me and the entire tree of objects I point to. An object in the tree twice is copied once, and both references point to him. deepCopier holds a dictionary of objects we have seen. See veryDeepInner:, veryDeepFixupWith:"
+
+ self prepareToBeSaved.
+ ^ super veryDeepCopyWith: deepCopier!
Item was added:
+ ----- Method: Morph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If some fields were weakly copied, fix new copy here."
+
+ "super veryDeepFixupWith: deepCopier. Object has no fixups, so don't call it"
+
+ "If my owner is being duplicated too, then store his duplicate.
+ If I am owned outside the duplicated tree, then I am no longer owned!!"
+ owner := deepCopier references at: owner ifAbsent: [nil].
+
+ !
Item was added:
+ ----- Method: Morph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "The inner loop, so it can be overridden when a field should not
+ be traced."
+ "super veryDeepInner: deepCopier. know Object has no inst vars"
+ bounds := bounds clone.
+ "Points are shared with original"
+ "owner := owner. special, see veryDeepFixupWith:"
+ submorphs := submorphs veryDeepCopyWith: deepCopier.
+ "each submorph's fixup will install me as the owner"
+ "fullBounds := fullBounds. fullBounds is shared with original!!"
+ color := color veryDeepCopyWith: deepCopier.
+ "color, if simple, will return self. may be complex"
+ extension := (extension veryDeepCopyWith: deepCopier)!
Item was added:
+ ----- Method: Morph>>viewBox (in category 'accessing') -----
+ viewBox
+ ^ self pasteUpMorph viewBox!
Item was added:
+ ----- Method: Morph>>viewMorphDirectly (in category 'debug and other') -----
+ viewMorphDirectly
+ "Open a Viewer directly on the Receiver, i.e. no Player involved"
+
+ self presenter viewObjectDirectly: self renderedMorph
+
+ !
Item was added:
+ ----- Method: Morph>>visible (in category 'drawing') -----
+ visible
+ "answer whether the receiver is visible"
+ extension ifNil: [^ true].
+ ^ extension visible!
Item was added:
+ ----- Method: Morph>>visible: (in category 'drawing') -----
+ visible: aBoolean
+ "set the 'visible' attribute of the receiver to aBoolean"
+ (extension isNil and:[aBoolean]) ifTrue: [^ self].
+ self visible == aBoolean ifTrue: [^ self].
+ self assureExtension visible: aBoolean.
+ self changed!
Item was added:
+ ----- Method: Morph>>visibleClearArea (in category 'accessing') -----
+ visibleClearArea
+ "Answer the receiver visible clear area. The intersection
+ between the clear area and the viewbox."
+ ^ self viewBox intersect: self clearArea!
Item was added:
+ ----- Method: Morph>>wantsBalloon (in category 'halos and balloon help') -----
+ wantsBalloon
+ "Answer true if receiver wants to show a balloon help text is a few moments."
+
+ ^ (self balloonText notNil) and: [Preferences balloonHelpEnabled]!
Item was added:
+ ----- Method: Morph>>wantsConnectorVocabulary (in category 'connectors-scripting') -----
+ wantsConnectorVocabulary
+ "Answer true if I want to show a 'connector' vocabulary"
+ ^false!
Item was added:
+ ----- Method: Morph>>wantsDirectionHandles (in category 'halos and balloon help') -----
+ wantsDirectionHandles
+ ^self valueOfProperty: #wantsDirectionHandles ifAbsent:[Preferences showDirectionHandles]!
Item was added:
+ ----- Method: Morph>>wantsDirectionHandles: (in category 'halos and balloon help') -----
+ wantsDirectionHandles: aBool
+ aBool == Preferences showDirectionHandles
+ ifTrue:[self removeProperty: #wantsDirectionHandles]
+ ifFalse:[self setProperty: #wantsDirectionHandles toValue: aBool].
+ !
Item was added:
+ ----- Method: Morph>>wantsDropFiles: (in category 'event handling') -----
+ wantsDropFiles: anEvent
+ "Return true if the receiver wants files dropped from the OS."
+ ^false!
Item was added:
+ ----- Method: Morph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
+ wantsDroppedMorph: aMorph event: evt
+ "Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. Note that for a successful drop operation both parties need to agree. The symmetric check is done automatically via aMorph wantsToBeDroppedInto: self."
+
+ ^self dropEnabled!
Item was added:
+ ----- Method: Morph>>wantsEveryMouseMove (in category 'event handling') -----
+ wantsEveryMouseMove
+ "Unless overridden, this method allows processing to skip mouse move events
+ when processing is lagging. No 'significant' event (down/up, etc) will be skipped."
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>wantsHalo (in category 'halos and balloon help') -----
+ wantsHalo
+ | topOwner |
+ ^(topOwner := self topRendererOrSelf owner) notNil
+ and: [topOwner wantsHaloFor: self]!
Item was added:
+ ----- Method: Morph>>wantsHaloFor: (in category 'halos and balloon help') -----
+ wantsHaloFor: aSubMorph
+ ^ false!
Item was added:
+ ----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') -----
+ wantsHaloFromClick
+ ^ true!
Item was added:
+ ----- Method: Morph>>wantsHaloHandleWithSelector:inHalo: (in category 'halos and balloon help') -----
+ wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph
+ "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)"
+
+ (#(addDismissHandle:) includes: aSelector) ifTrue:
+ [^ self resistsRemoval not].
+
+ (#( addDragHandle: ) includes: aSelector) ifTrue:
+ [^ self okayToBrownDragEasily].
+
+ (#(addGrowHandle: addScaleHandle:) includes: aSelector) ifTrue:
+ [^ self okayToResizeEasily].
+
+ (#( addRotateHandle: ) includes: aSelector) ifTrue:
+ [^ self okayToRotateEasily].
+
+ (#(addRecolorHandle:) includes: aSelector) ifTrue:
+ [^ self renderedMorph wantsRecolorHandle].
+
+ true ifTrue: [^ true]
+ !
Item was added:
+ ----- Method: Morph>>wantsKeyboardFocus (in category 'event handling') -----
+ wantsKeyboardFocus
+ "Whether this morph should get the current keyboard focus when handling a keyboard event to speed up further event processing."
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>wantsKeyboardFocusFor: (in category 'event handling') -----
+ wantsKeyboardFocusFor: aSubmorph
+ "Answer whether a plain mouse click on aSubmorph, a text-edit-capable thing, should result in a text selection there"
+ ^ false!
Item was added:
+ ----- Method: Morph>>wantsRecolorHandle (in category 'e-toy support') -----
+ wantsRecolorHandle
+ "Answer whether the receiver would like a recoloring halo handle to be put up. Since this handle also presently affords access to the property-sheet, it is presently always allowed, even though SketchMorphs don't like regular recoloring"
+
+ ^ true
+
+ !
Item was added:
+ ----- Method: Morph>>wantsRoundedCorners (in category 'rounding') -----
+ wantsRoundedCorners
+ "Return true if the receiver wants its corners rounded"
+ ^ self cornerStyle == #rounded!
Item was added:
+ ----- Method: Morph>>wantsScriptorHaloHandle (in category 'halos and balloon help') -----
+ wantsScriptorHaloHandle
+ "Answer whether the receiver would like to have a Scriptor halo handle put up on its behalf. Initially, only the ScriptableButton says yes"
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>wantsSimpleSketchMorphHandles (in category 'halos and balloon help') -----
+ wantsSimpleSketchMorphHandles
+ "Answer true if my halo's simple handles should include the simple sketch morph handles."
+ ^false!
Item was added:
+ ----- Method: Morph>>wantsSteps (in category 'testing') -----
+ wantsSteps
+ "Return true if the receiver overrides the default Morph step method."
+ "Details: Find first class in superclass chain that implements #step and return true if it isn't class Morph."
+
+ | c |
+ self isPartsDonor ifTrue: [^ false].
+ (self == self topRendererOrSelf) ifTrue: [self player wantsSteps ifTrue: [^ true]].
+ c := self class.
+ [c includesSelector: #step] whileFalse: [c := c superclass].
+ ^ c ~= Morph!
Item was added:
+ ----- Method: Morph>>wantsToBeCachedByHand (in category 'accessing') -----
+ wantsToBeCachedByHand
+ "Return true if the receiver wants to be cached by the hand when it is dragged around.
+ Note: The default implementation queries all submorphs since subclasses may have shapes that do not fill the receiver's bounds completely."
+ self hasTranslucentColor ifTrue:[^false].
+ self submorphsDo:[:m|
+ m wantsToBeCachedByHand ifFalse:[^false].
+ ].
+ ^true!
Item was added:
+ ----- Method: Morph>>wantsToBeDroppedInto: (in category 'dropping/grabbing') -----
+ wantsToBeDroppedInto: aMorph
+ "Return true if it's okay to drop the receiver into aMorph. This check is symmetric to #wantsDroppedMorph:event: to give both parties a chance of figuring out whether they like each other."
+ ^true!
Item was added:
+ ----- Method: Morph>>wantsToBeOpenedInWorld (in category 'dropping/grabbing') -----
+ wantsToBeOpenedInWorld
+ "Return true if the receiver wants to be put into the World directly,
+ rather than allowing the user to place it (e.g., prevent attaching me
+ to the hand after choosing 'new morph' in the world menu)"
+ ^false!
Item was added:
+ ----- Method: Morph>>wantsToBeTopmost (in category 'accessing') -----
+ wantsToBeTopmost
+ "Answer if the receiver want to be one of the topmost objects in its owner"
+ ^ self isFlapOrTab!
Item was added:
+ ----- Method: Morph>>wantsWindowEvents: (in category 'event handling') -----
+ wantsWindowEvents: anEvent
+ "Return true if the receiver wants to process host window events. These are only dispatched to the World anyway, but one could have an eventListener in the Hand or a windowEventHandler in the World"
+ ^false!
Item was added:
+ ----- Method: Morph>>wantsYellowButtonMenu (in category 'menu') -----
+ wantsYellowButtonMenu
+ "Answer true if the receiver wants a yellow button menu"
+ self
+ valueOfProperty: #wantsYellowButtonMenu
+ ifPresentDo: [:value | ^ value].
+ ""
+ self isInSystemWindow
+ ifTrue: [^ false].""
+ (Preferences noviceMode
+ and: [self isInDockingBar])
+ ifTrue: [^ false].""
+ ^ Preferences generalizedYellowButtonMenu!
Item was added:
+ ----- Method: Morph>>wantsYellowButtonMenu: (in category 'menu') -----
+ wantsYellowButtonMenu: aBoolean
+ "Change the receiver to wants or not a yellow button menu"
+ self setProperty: #wantsYellowButtonMenu toValue: aBoolean!
Item was added:
+ ----- Method: Morph>>width (in category 'geometry') -----
+ width
+
+ ^ bounds width!
Item was added:
+ ----- Method: Morph>>width: (in category 'geometry') -----
+ width: aNumber
+ " Set my width; my position (top-left corner) and height will remain the same "
+
+ self extent: aNumber asInteger at self height.
+ !
Item was added:
+ ----- Method: Morph>>willingToBeDiscarded (in category 'dropping/grabbing') -----
+ willingToBeDiscarded
+ ^ true!
Item was added:
+ ----- Method: Morph>>windowEvent: (in category 'event handling') -----
+ windowEvent: anEvent
+ "Host window event"!
Item was added:
+ ----- Method: Morph>>withAllOwners (in category 'structure') -----
+ withAllOwners
+ "Return the receiver and all its owners"
+
+ ^ Array streamContents: [:strm | self withAllOwnersDo: [:m | strm nextPut: m]]!
Item was added:
+ ----- Method: Morph>>withAllOwnersDo: (in category 'structure') -----
+ withAllOwnersDo: aBlock
+ "Evaluate aBlock with the receiver and all of its owners"
+ aBlock value: self.
+ owner ifNotNil:[^owner withAllOwnersDo: aBlock].!
Item was added:
+ ----- Method: Morph>>world (in category 'structure') -----
+ world
+ ^owner isNil ifTrue: [nil] ifFalse: [owner world]!
Item was added:
+ ----- Method: Morph>>worldBounds (in category 'geometry') -----
+ worldBounds
+ ^ self world bounds!
Item was added:
+ ----- Method: Morph>>worldBoundsForHalo (in category 'geometry') -----
+ worldBoundsForHalo
+ "Answer the rectangle to be used as the inner dimension of my halos.
+ Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle."
+
+ | r |
+ r := (Preferences haloEnclosesFullBounds)
+ ifFalse: [ self boundsIn: nil ]
+ ifTrue: [ self fullBoundsInWorld ].
+ Preferences showBoundsInHalo ifTrue: [ ^r outsetBy: 2 ].
+ ^r!
Item was added:
+ ----- Method: Morph>>wouldAcceptKeyboardFocus (in category 'event handling') -----
+ wouldAcceptKeyboardFocus
+ "Answer whether a plain mouse click on the receiver should result in a text selection there"
+ ^ false!
Item was added:
+ ----- Method: Morph>>wouldAcceptKeyboardFocusUponTab (in category 'event handling') -----
+ wouldAcceptKeyboardFocusUponTab
+ "Answer whether the receiver is in the running as the new keyboard focus if the tab key were hit at a meta level. This provides the leverage for tabbing among fields of a card, for example."
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>wrapCentering (in category 'layout-properties') -----
+ wrapCentering
+ "Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
+ #topLeft - center at start of secondary direction
+ #bottomRight - center at end of secondary direction
+ #center - center in the middle of secondary direction
+ #justified - insert extra space inbetween rows/columns
+ "
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#topLeft] ifNotNil:[props wrapCentering].!
Item was added:
+ ----- Method: Morph>>wrapCentering: (in category 'layout-properties') -----
+ wrapCentering: aSymbol
+ "Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
+ #topLeft - center at start of secondary direction
+ #bottomRight - center at end of secondary direction
+ #center - center in the middle of secondary direction
+ #justified - insert extra space inbetween rows/columns
+ "
+ self assureTableProperties wrapCentering: aSymbol.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>wrapCenteringString: (in category 'layout-properties') -----
+ wrapCenteringString: aSymbol
+ ^self layoutMenuPropertyString: aSymbol from: self wrapCentering!
Item was added:
+ ----- Method: Morph>>wrapDirection (in category 'layout-properties') -----
+ wrapDirection
+ "Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are:
+ #leftToRight
+ #rightToLeft
+ #topToBottom
+ #bottomToTop
+ #none
+ indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa."
+ | props |
+ props := self layoutProperties.
+ ^props ifNil:[#none] ifNotNil:[props wrapDirection].!
Item was added:
+ ----- Method: Morph>>wrapDirection: (in category 'layout-properties') -----
+ wrapDirection: aSymbol
+ "Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are:
+ #leftToRight
+ #rightToLeft
+ #topToBottom
+ #bottomToTop
+ #none
+ indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa."
+ self assureTableProperties wrapDirection: aSymbol.
+ self layoutChanged.
+ !
Item was added:
+ ----- Method: Morph>>wrapDirectionString: (in category 'layout-properties') -----
+ wrapDirectionString: aSymbol
+ ^self layoutMenuPropertyString: aSymbol from: self wrapDirection !
Item was added:
+ ----- Method: Morph>>wrappedInWindow: (in category 'e-toy support') -----
+ wrappedInWindow: aSystemWindow
+ | aWindow |
+ aWindow := aSystemWindow model: Model new.
+ aWindow addMorph: self frame: (0 at 0 extent: 1 at 1).
+ aWindow extent: self extent.
+ ^ aWindow!
Item was added:
+ ----- Method: Morph>>wrappedInWindowWithTitle: (in category 'e-toy support') -----
+ wrappedInWindowWithTitle: aTitle
+ | aWindow w2 |
+ aWindow := (SystemWindow labelled: aTitle) model: Model new.
+ aWindow addMorph: self frame: (0 at 0 extent: 1 at 1).
+ w2 := aWindow borderWidth * 2.
+ w2 := 3. "oh, well"
+ aWindow extent: self fullBounds extent + (0 @ aWindow labelHeight) + (w2 @ w2).
+ ^ aWindow!
Item was added:
+ ----- Method: Morph>>yellowButtonActivity: (in category 'event handling') -----
+ yellowButtonActivity: shiftState
+ "Find me or my outermost owner that has items to add to a
+ yellow button menu.
+ shiftState is true if the shift was pressed.
+ Otherwise, build a menu that contains the contributions from
+ myself and my interested submorphs,
+ and present it to the user."
+ | menu |
+ self isWorldMorph
+ ifFalse: [| outerOwner |
+ outerOwner := self outermostOwnerWithYellowButtonMenu.
+ outerOwner
+ ifNil: [^ self].
+ outerOwner == self
+ ifFalse: [^ outerOwner yellowButtonActivity: shiftState]].
+ menu := self buildYellowButtonMenu: ActiveHand.
+ menu
+ addTitle: self externalName
+ icon: (self iconOrThumbnailOfSize: (Preferences tinyDisplay ifTrue: [16] ifFalse: [28])).
+ menu popUpInWorld: self currentWorld!
Item was added:
+ ----- Method: Morph>>yellowButtonGestureDictionaryOrName: (in category 'geniestubs') -----
+ yellowButtonGestureDictionaryOrName: aSymbolOrDictionary!
Item was added:
+ Object subclass: #MorphExtension
+ instanceVariableNames: 'locked visible sticky balloonText balloonTextSelector externalName isPartsDonor actorState player eventHandler otherProperties'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Kernel'!
+
+ !MorphExtension commentStamp: '<historical>' prior: 0!
+ MorphExtension provides access to extra instance state that is not required in most simple morphs. This allows simple morphs to remain relatively lightweight while still admitting more complex structures as necessary. The otherProperties field takes this policy to the extreme of allowing any number of additional named attributes, albeit at a certain cost in speed and space.!
Item was added:
+ ----- Method: MorphExtension>>actorState (in category 'accessing') -----
+ actorState
+ "answer the redeiver's actorState"
+ ^ actorState !
Item was added:
+ ----- Method: MorphExtension>>actorState: (in category 'accessing') -----
+ actorState: anActorState
+ "change the receiver's actorState"
+ actorState := anActorState!
Item was added:
+ ----- Method: MorphExtension>>assureOtherProperties (in category 'accessing - other properties') -----
+ assureOtherProperties
+ "creates an otherProperties for the receiver if needed"
+ otherProperties ifNil: [self initializeOtherProperties].
+ ^ otherProperties!
Item was added:
+ ----- Method: MorphExtension>>balloonText (in category 'accessing') -----
+ balloonText
+ ^ balloonText!
Item was added:
+ ----- Method: MorphExtension>>balloonText: (in category 'accessing') -----
+ balloonText: newValue
+ balloonText := newValue!
Item was added:
+ ----- Method: MorphExtension>>balloonTextSelector (in category 'accessing') -----
+ balloonTextSelector
+ ^ balloonTextSelector!
Item was added:
+ ----- Method: MorphExtension>>balloonTextSelector: (in category 'accessing') -----
+ balloonTextSelector: aSymbol
+ "change the receiver's balloonTextSelector"
+ balloonTextSelector := aSymbol!
Item was added:
+ ----- Method: MorphExtension>>comeFullyUpOnReload: (in category 'objects from disk') -----
+ comeFullyUpOnReload: smartRefStream
+ "inst vars have default booplean values."
+
+ locked ifNil: [locked := false].
+ visible ifNil: [visible := true].
+ sticky ifNil: [sticky := false].
+ isPartsDonor ifNil: [isPartsDonor := false].
+ ^ self!
Item was added:
+ ----- Method: MorphExtension>>copyWeakly (in category 'connectors-copying') -----
+ copyWeakly
+ "list of names of properties whose values should be weak-copied when veryDeepCopying a morph. See DeepCopier."
+
+ ^ #(formerOwner newPermanentPlayer logger graphModel gestureDictionaryOrName)
+ "add yours to this list"
+
+ "formerOwner should really be nil at the time of the copy, but this will work just fine."!
Item was added:
+ ----- Method: MorphExtension>>eventHandler (in category 'accessing') -----
+ eventHandler
+ "answer the receiver's eventHandler"
+ ^ eventHandler !
Item was added:
+ ----- Method: MorphExtension>>eventHandler: (in category 'accessing') -----
+ eventHandler: newValue
+ eventHandler := newValue!
Item was added:
+ ----- Method: MorphExtension>>externalName (in category 'viewer') -----
+ externalName
+ ^ externalName!
Item was added:
+ ----- Method: MorphExtension>>externalName: (in category 'accessing') -----
+ externalName: aString
+ "change the receiver's externalName"
+ externalName := aString!
Item was added:
+ ----- Method: MorphExtension>>hasOtherProperties (in category 'accessing - other properties') -----
+ hasOtherProperties
+ "answer whether the receiver has otherProperties"
+ ^ otherProperties notNil!
Item was added:
+ ----- Method: MorphExtension>>hasProperty: (in category 'accessing - other properties') -----
+ hasProperty: aSymbol
+ "Answer whether the receiver has the property named aSymbol"
+ | property |
+ otherProperties ifNil: [^ false].
+ property := otherProperties at: aSymbol ifAbsent: [].
+ property isNil ifTrue: [^ false].
+ property == false ifTrue: [^ false].
+ ^ true!
Item was added:
+ ----- Method: MorphExtension>>initialize (in category 'initialization') -----
+ initialize
+ "Init all booleans to default values"
+ locked := false.
+ visible := true.
+ sticky := false.
+ isPartsDonor := false.
+ !
Item was added:
+ ----- Method: MorphExtension>>initializeOtherProperties (in category 'accessing - other properties') -----
+ initializeOtherProperties
+ "private - initializes the receiver's otherProperties"
+ otherProperties := IdentityDictionary new!
Item was added:
+ ----- Method: MorphExtension>>inspectElement (in category 'other') -----
+ inspectElement
+ "Create and schedule an Inspector on the otherProperties and the
+ named properties."
+ | key obj |
+ key := UIManager default chooseFrom: self sortedPropertyNames values: self sortedPropertyNames title: 'Inspect which property?'.
+ key
+ ifNil: [^ self].
+ obj := otherProperties
+ at: key
+ ifAbsent: ['nOT a vALuE'].
+ obj = 'nOT a vALuE'
+ ifTrue: [(self perform: key) inspect
+ "named properties"]
+ ifFalse: [obj inspect]!
Item was added:
+ ----- Method: MorphExtension>>isDefault (in category 'other') -----
+ isDefault
+ "Return true if the receiver is a default and can be omitted"
+ locked == true
+ ifTrue: [^ false].
+ visible == false
+ ifTrue: [^ false].
+ sticky == true
+ ifTrue: [^ false].
+ balloonText isNil
+ ifFalse: [^ false].
+ balloonTextSelector isNil
+ ifFalse: [^ false].
+ externalName isNil
+ ifFalse: [^ false].
+ isPartsDonor == true
+ ifTrue: [^ false].
+ actorState isNil
+ ifFalse: [^ false].
+ player isNil
+ ifFalse: [^ false].
+ eventHandler isNil
+ ifFalse: [^ false].
+ otherProperties ifNotNil: [otherProperties isEmpty ifFalse: [^ false]].
+ ^ true!
Item was added:
+ ----- Method: MorphExtension>>isPartsDonor (in category 'parts bin') -----
+ isPartsDonor
+ "answer whether the receiver is PartsDonor"
+ ^ isPartsDonor!
Item was added:
+ ----- Method: MorphExtension>>isPartsDonor: (in category 'parts bin') -----
+ isPartsDonor: aBoolean
+ "change the receiver's isPartDonor property"
+ isPartsDonor := aBoolean!
Item was added:
+ ----- Method: MorphExtension>>layoutFrame (in category 'accessing - layout properties') -----
+ layoutFrame
+ ^self valueOfProperty: #layoutFrame!
Item was added:
+ ----- Method: MorphExtension>>layoutFrame: (in category 'accessing - layout properties') -----
+ layoutFrame: aLayoutFrame
+ aLayoutFrame isNil
+ ifTrue: [self removeProperty: #layoutFrame]
+ ifFalse: [self setProperty: #layoutFrame toValue: aLayoutFrame]!
Item was added:
+ ----- Method: MorphExtension>>layoutPolicy (in category 'accessing - layout properties') -----
+ layoutPolicy
+ ^self valueOfProperty: #layoutPolicy!
Item was added:
+ ----- Method: MorphExtension>>layoutPolicy: (in category 'accessing - layout properties') -----
+ layoutPolicy: aLayoutPolicy
+ aLayoutPolicy isNil
+ ifTrue: [self removeProperty: #layoutPolicy]
+ ifFalse: [self setProperty: #layoutPolicy toValue: aLayoutPolicy]!
Item was added:
+ ----- Method: MorphExtension>>layoutProperties (in category 'accessing - layout properties') -----
+ layoutProperties
+ ^self valueOfProperty: #layoutProperties!
Item was added:
+ ----- Method: MorphExtension>>layoutProperties: (in category 'accessing - layout properties') -----
+ layoutProperties: newProperties
+ "Return the current layout properties associated with the receiver"
+
+ newProperties isNil
+ ifTrue: [self removeProperty: #layoutProperties]
+ ifFalse: [self setProperty: #layoutProperties toValue: newProperties]!
Item was added:
+ ----- Method: MorphExtension>>locked (in category 'accessing') -----
+ locked
+ "answer whether the receiver is Locked"
+ ^ locked!
Item was added:
+ ----- Method: MorphExtension>>locked: (in category 'accessing') -----
+ locked: aBoolean
+ "change the receiver's locked property"
+ locked := aBoolean!
Item was added:
+ ----- Method: MorphExtension>>otherProperties (in category 'accessing - other properties') -----
+ otherProperties
+ "answer the receiver's otherProperties"
+ ^ otherProperties!
Item was added:
+ ----- Method: MorphExtension>>player (in category 'accessing') -----
+ player
+ "answer the receiver's player"
+ ^ player!
Item was added:
+ ----- Method: MorphExtension>>player: (in category 'accessing') -----
+ player: anObject
+ "change the receiver's player"
+ player := anObject !
Item was added:
+ ----- Method: MorphExtension>>printOn: (in category 'printing') -----
+ printOn: aStream
+ "Append to the argument, aStream, a sequence of characters that
+ identifies the receiver."
+ super printOn: aStream.
+ aStream nextPutAll: ' ' , self identityHashPrintString.
+ locked == true
+ ifTrue: [aStream nextPutAll: ' [locked] '].
+ visible == false
+ ifTrue: [aStream nextPutAll: '[not visible] '].
+ sticky == true
+ ifTrue: [aStream nextPutAll: ' [sticky] '].
+ balloonText
+ ifNotNil: [aStream nextPutAll: ' [balloonText] '].
+ balloonTextSelector
+ ifNotNil: [aStream nextPutAll: ' [balloonTextSelector: ' , balloonTextSelector printString , '] '].
+ externalName
+ ifNotNil: [aStream nextPutAll: ' [externalName = ' , externalName , ' ] '].
+ isPartsDonor == true
+ ifTrue: [aStream nextPutAll: ' [isPartsDonor] '].
+ player
+ ifNotNil: [aStream nextPutAll: ' [player = ' , player printString , '] '].
+ eventHandler
+ ifNotNil: [aStream nextPutAll: ' [eventHandler = ' , eventHandler printString , '] '].
+ (otherProperties isNil or: [otherProperties isEmpty ]) ifTrue: [^ self].
+ aStream nextPutAll: ' [other: '.
+ self otherProperties
+ keysDo: [:aKey | aStream nextPutAll: ' (' , aKey , ' -> ' , (self otherProperties at: aKey) printString , ')'].
+ aStream nextPut: $]!
Item was added:
+ ----- Method: MorphExtension>>privateOtherProperties: (in category 'accessing - other properties') -----
+ privateOtherProperties: anIdentityDictionary
+ "private - change the receiver's otherProperties"
+ otherProperties := anIdentityDictionary !
Item was added:
+ ----- Method: MorphExtension>>propertyNamesNotCopied (in category 'connectors-copying') -----
+ propertyNamesNotCopied
+ "list of names of properties whose values should be deleted when veryDeepCopying a morph.
+ See DeepCopier."
+
+ ^ #(connectedConstraints connectionHighlights highlightedTargets)
+ "add yours to this list"
+ !
Item was added:
+ ----- Method: MorphExtension>>removeOtherProperties (in category 'accessing - other properties') -----
+ removeOtherProperties
+ "Remove the 'other' properties"
+ otherProperties := nil!
Item was added:
+ ----- Method: MorphExtension>>removeProperty: (in category 'accessing - other properties') -----
+ removeProperty: aSymbol
+ "removes the property named aSymbol if it exists"
+ otherProperties ifNil: [^ self].
+ otherProperties removeKey: aSymbol ifAbsent: [].
+ otherProperties isEmpty ifTrue: [self removeOtherProperties]!
Item was added:
+ ----- Method: MorphExtension>>setProperty:toValue: (in category 'accessing - other properties') -----
+ setProperty: aSymbol toValue: abObject
+ "change the receiver's property named aSymbol to anObject"
+ self assureOtherProperties at: aSymbol put: abObject!
Item was added:
+ ----- Method: MorphExtension>>sortedPropertyNames (in category 'accessing - other properties') -----
+ sortedPropertyNames
+ "answer the receiver's property names in a sorted way"
+
+ | props |
+ props := WriteStream on: (Array new: 10).
+ locked == true ifTrue: [props nextPut: #locked].
+ visible == false ifTrue: [props nextPut: #visible].
+ sticky == true ifTrue: [props nextPut: #sticky].
+ balloonText isNil ifFalse: [props nextPut: #balloonText].
+ balloonTextSelector isNil ifFalse: [props nextPut: #balloonTextSelector].
+ externalName isNil ifFalse: [props nextPut: #externalName].
+ isPartsDonor == true ifTrue: [props nextPut: #isPartsDonor].
+ actorState isNil ifFalse: [props nextPut: #actorState].
+ player isNil ifFalse: [props nextPut: #player].
+ eventHandler isNil ifFalse: [props nextPut: #eventHandler].
+ otherProperties ifNotNil: [otherProperties associationsDo: [:a | props nextPut: a key]].
+ ^props contents sort: [:s1 :s2 | s1 <= s2]!
Item was added:
+ ----- Method: MorphExtension>>sticky (in category 'accessing') -----
+ sticky
+ ^ sticky!
Item was added:
+ ----- Method: MorphExtension>>sticky: (in category 'accessing') -----
+ sticky: aBoolean
+ "change the receiver's sticky property"
+ sticky := aBoolean!
Item was added:
+ ----- Method: MorphExtension>>valueOfProperty: (in category 'accessing - other properties') -----
+ valueOfProperty: aSymbol
+ "answer the value of the receiver's property named aSymbol"
+
+ ^otherProperties ifNotNil: [ otherProperties at: aSymbol ifAbsent: nil ]!
Item was added:
+ ----- Method: MorphExtension>>valueOfProperty:ifAbsent: (in category 'accessing - other properties') -----
+ valueOfProperty: aSymbol ifAbsent: aBlock
+ "if the receiver possesses a property of the given name, answer
+ its value. If not then evaluate aBlock and answer the result of
+ this block evaluation"
+ otherProperties ifNil: [^ aBlock value].
+ ^otherProperties at: aSymbol ifAbsent: aBlock!
Item was added:
+ ----- Method: MorphExtension>>valueOfProperty:ifAbsentPut: (in category 'accessing - other properties') -----
+ valueOfProperty: aSymbol ifAbsentPut: aBlock
+ "If the receiver possesses a property of the given name, answer
+ its value. If not, then create a property of the given name, give
+ it the value obtained by evaluating aBlock, then answer that
+ value"
+ ^self assureOtherProperties at: aSymbol ifAbsentPut: aBlock!
Item was added:
+ ----- Method: MorphExtension>>veryDeepFixupWith: (in category 'connectors-copying') -----
+ veryDeepFixupWith: deepCopier
+ "If target and arguments fields were weakly copied, fix them here.
+ If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ otherProperties ifNil: [ ^self ].
+
+ "Properties whose values are only copied weakly replace those values if they were copied via another path"
+ self copyWeakly do: [ :propertyName |
+ otherProperties at: propertyName ifPresent: [ :property |
+ otherProperties at: propertyName
+ put: (deepCopier references at: property ifAbsent: [ property ])]].
+ !
Item was added:
+ ----- Method: MorphExtension>>veryDeepInner: (in category 'connectors-copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables.
+ Some otherProperties need to be not copied at all, but shared. Their names are given by copyWeakly.
+ Some otherProperties should not be copied or shared. Their names are given by propertyNamesNotCopied.
+ This is special code for the dictionary. See DeepCopier, and veryDeepFixupWith:."
+
+ | namesOfWeaklyCopiedProperties weaklyCopiedValues |
+ super veryDeepInner: deepCopier.
+ locked := locked veryDeepCopyWith: deepCopier.
+ visible := visible veryDeepCopyWith: deepCopier.
+ sticky := sticky veryDeepCopyWith: deepCopier.
+ balloonText := balloonText veryDeepCopyWith: deepCopier.
+ balloonTextSelector := balloonTextSelector veryDeepCopyWith: deepCopier.
+ externalName := externalName veryDeepCopyWith: deepCopier.
+ isPartsDonor := isPartsDonor veryDeepCopyWith: deepCopier.
+ actorState := actorState veryDeepCopyWith: deepCopier.
+ player := player veryDeepCopyWith: deepCopier. "Do copy the player of this morph"
+ eventHandler := eventHandler veryDeepCopyWith: deepCopier. "has its own restrictions"
+
+ otherProperties ifNil: [ ^self ].
+
+ otherProperties := otherProperties copy.
+ self propertyNamesNotCopied do: [ :propName | otherProperties removeKey: propName ifAbsent: [] ].
+
+ namesOfWeaklyCopiedProperties := self copyWeakly.
+ weaklyCopiedValues := namesOfWeaklyCopiedProperties collect: [ :propName | otherProperties removeKey: propName ifAbsent: [] ].
+
+ "Now copy all the others."
+ otherProperties := otherProperties veryDeepCopyWith: deepCopier.
+
+ "And replace the weak ones."
+ namesOfWeaklyCopiedProperties with: weaklyCopiedValues do: [ :name :value | value ifNotNil: [ otherProperties at: name put: value ]].
+ !
Item was added:
+ ----- Method: MorphExtension>>visible (in category 'accessing') -----
+ visible
+ "answer whether the receiver is visible"
+ ^ visible!
Item was added:
+ ----- Method: MorphExtension>>visible: (in category 'accessing') -----
+ visible: newValue
+ visible := newValue!
Item was added:
+ Object subclass: #MorphHierarchy
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: MorphHierarchy class>>openOrDelete (in category 'opening') -----
+ openOrDelete
+ | oldMorph |
+ oldMorph := World submorphs
+ detect: [:each | each hasProperty: #morphHierarchy]
+ ifNone: [| newMorph |
+ newMorph := self new asMorph.
+ newMorph bottomLeft: ActiveHand position.
+ newMorph openInWorld.
+ newMorph isFullOnScreen
+ ifFalse: [newMorph goHome].
+ ^ self].
+ ""
+ oldMorph delete!
Item was added:
+ ----- Method: MorphHierarchy>>asMorph (in category 'private') -----
+ asMorph
+ "Answer the morph version of the receiver"
+ | morph |
+ morph := MorphHierarchyListMorph
+ on: self
+ list: #roots
+ selected: nil
+ changeSelected: #selected:.
+ ""
+ ^ morph inAContainer!
Item was added:
+ ----- Method: MorphHierarchy>>roots (in category 'accessing') -----
+ roots
+ "Answer the roots for the Object Hierarchy, that means answer the World"
+ ^ {MorphListItemWrapper with: World}!
Item was added:
+ ----- Method: MorphHierarchy>>selected: (in category 'accessing') -----
+ selected: aMorphListItemWrapper
+ "Change the selected object"
+ | newSelection |
+ aMorphListItemWrapper isNil
+ ifTrue: [^ self].
+ newSelection := aMorphListItemWrapper withoutListWrapper.
+ newSelection == World selectedObject
+ ifTrue: [newSelection removeHalo]
+ ifFalse: [newSelection addHalo].
+ self changed: #selected!
Item was added:
+ SimpleHierarchicalListMorph subclass: #MorphHierarchyListMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: MorphHierarchyListMorph>>createContainer (in category 'private') -----
+ createContainer
+ "Private - Create a container"
+ | container |
+ container := BorderedMorph new.
+ container extent: (World extent * (1 / 4 @ (2 / 3))) rounded.
+ container layoutPolicy: TableLayout new.
+ container hResizing: #rigid.
+ container vResizing: #rigid.
+ container
+ setColor: Preferences menuColor
+ borderWidth: Preferences menuBorderWidth
+ borderColor: Preferences menuBorderColor.
+ container layoutInset: 0.
+ "container useRoundedCorners."
+ ""
+ container setProperty: #morphHierarchy toValue: true.
+ container setNameTo: 'Objects Hierarchy' translated.
+ ""
+ ^ container!
Item was added:
+ ----- Method: MorphHierarchyListMorph>>inAContainer (in category 'private') -----
+ inAContainer
+ "Answer the receiver contained in a proper container"
+ | container |
+ container := self createContainer.
+ container addMorphBack: self.
+ "
+ nasty hack to force the scroolbar recreation"
+ self extent: container extent - container borderWidth.
+ ""
+ ^ container!
Item was added:
+ ----- Method: MorphHierarchyListMorph>>on:list:selected:changeSelected:menu:keystroke: (in category 'initialization') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
+ super
+ on: anObject
+ list: getListSel
+ selected: getSelectionSel
+ changeSelected: setSelectionSel
+ menu: getMenuSel
+ keystroke: keyActionSel.
+ ""
+ self borderWidth: 0.
+ self autoDeselect: false.
+ self enableDrag: false.
+ self enableDrop: true.
+ self hResizing: #spaceFill.
+ self vResizing: #spaceFill.
+ self expandRoots!
Item was added:
+ ----- Method: MorphHierarchyListMorph>>setSelectedMorph: (in category 'selection') -----
+ setSelectedMorph: aMorph
+ super setSelectedMorph: aMorph.
+ self owner isNil ifFalse:[self owner delete]!
Item was added:
+ ListItemWrapper subclass: #MorphListItemWrapper
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: MorphListItemWrapper>>asString (in category 'converting') -----
+ asString
+ "Answer the string representation of the receiver"
+ ^ item externalName!
Item was added:
+ ----- Method: MorphListItemWrapper>>contents (in category 'accessing') -----
+ contents
+ "Answer the receiver's contents"
+
+ | tentative submorphs |
+ tentative := item submorphs
+ collect: [:each | each renderedMorph].
+
+ submorphs := Preferences noviceMode
+ ifTrue: [
+ tentative
+ reject: [:each |
+ each isSystemWindow
+ or: [each isDockingBar
+ or: [(each isKindOf: HaloMorph)
+ or: [(each hasProperty: #morphHierarchy)
+ or: [each isFlapOrTab
+ or: [each isObjectsTool]]]]]]]
+ ifFalse: [
+ tentative
+ reject: [:each | each isKindOf: HaloMorph]].
+
+ ^ submorphs
+ collect: [:each | self class with: each]!
Item was added:
+ ----- Method: MorphListItemWrapper>>icon (in category 'accessing') -----
+ icon
+ "Answer a form to be used as icon"
+ ^ item iconOrThumbnailOfSize: ((Preferences tinyDisplay ifTrue: [16] ifFalse: [28]))!
Item was added:
+ ListItemWrapper subclass: #MorphWithSubmorphsWrapper
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
+
+ !MorphWithSubmorphsWrapper commentStamp: 'ls 3/1/2004 17:32' prior: 0!
+ Display a morph in a SimpleHierarchicalListMorph, and arrange to recursively display the morph's submorphs. The "item" that is wrapped is the morph to display.!
Item was added:
+ ----- Method: MorphWithSubmorphsWrapper>>contents (in category 'hierarchy') -----
+ contents
+ ^item submorphs collect: [ :m |
+ self class with: m ]!
Item was added:
+ MessageSend subclass: #MorphicAlarm
+ instanceVariableNames: 'scheduledTime sequenceNumber numArgs'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: MorphicAlarm class>>scheduledAt:receiver:selector:arguments: (in category 'instance creation') -----
+ scheduledAt: scheduledTime receiver: aTarget selector: aSelector arguments: argArray
+ ^(self receiver: aTarget selector: aSelector arguments: argArray)
+ scheduledTime: scheduledTime.!
Item was added:
+ ----- Method: MorphicAlarm>>scheduledTime (in category 'accessing') -----
+ scheduledTime
+ "Return the time (in milliseconds) that the receiver is scheduled to be executed"
+ ^scheduledTime!
Item was added:
+ ----- Method: MorphicAlarm>>scheduledTime: (in category 'accessing') -----
+ scheduledTime: msecs
+ "Set the time (in milliseconds) that the receiver is scheduled to be executed"
+ scheduledTime := msecs!
Item was added:
+ ----- Method: MorphicAlarm>>sequenceNumber (in category 'accessing') -----
+ sequenceNumber
+ "Answer the sequence number of the alarm, which is used to preserve ordering for alarms scheduled for the same time."
+ ^sequenceNumber ifNil: [0]!
Item was added:
+ ----- Method: MorphicAlarm>>sequenceNumber: (in category 'accessing') -----
+ sequenceNumber: positiveInteger
+ "Set the sequence number of the alarm, which is used to preserve ordering for alarms scheduled for the same time."
+ sequenceNumber := positiveInteger!
Item was added:
+ ----- Method: MorphicAlarm>>value: (in category 'evaluating') -----
+ value: anArgument
+ | nArgs |
+ numArgs ifNil:[numArgs := selector numArgs].
+ nArgs := arguments ifNil:[0] ifNotNil:[arguments size].
+ nArgs = numArgs ifTrue:[
+ "Ignore extra argument"
+ ^self value].
+ ^arguments
+ ifNil: [ receiver perform: selector with: anArgument]
+ ifNotNil: [ receiver perform: selector withArguments: (arguments copyWith: anArgument)]!
Item was added:
+ Heap subclass: #MorphicAlarmQueue
+ instanceVariableNames: 'mutex sequenceNumber'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
+
+ !MorphicAlarmQueue commentStamp: 'jcg 1/9/2010 13:34' prior: 0!
+ MorphicAlarmQueue is a specialized Heap. The main change is to stamp each added MorphicAlarm with a sequence number to ensure that alarms scheduled for the same time are executed in the order that they were added.!
Item was added:
+ ----- Method: MorphicAlarmQueue class>>convertAllAlarms (in category 'class initialization') -----
+ convertAllAlarms
+ "Alarms should be kept in a MorphicAlarmQueue, not a Heap."
+ WorldState allSubInstancesDo: [:ws | ws convertAlarms]!
Item was added:
+ ----- Method: MorphicAlarmQueue class>>initialize (in category 'class initialization') -----
+ initialize
+ self convertAllAlarms.!
Item was added:
+ ----- Method: MorphicAlarmQueue>>add: (in category 'adding') -----
+ add: aMorphicAlarm
+ (sequenceNumber := sequenceNumber + 1) = 16r3FFFFFFF ifTrue: [
+ "Sequence number overflow... reassign sequence numbers starting at 0."
+ | alarmList |
+ alarmList := self asArray sort: [:msg1 :msg2 |
+ msg1 sequenceNumber < msg2 sequenceNumber
+ ].
+ alarmList withIndexDo: [:msg :ind | msg sequenceNumber: ind-1].
+ "The #bitAnd: for the unlikely event that we have > 16r3FFFFFF messages in the queue."
+ sequenceNumber := alarmList last sequenceNumber + 1 bitAnd: 16r3FFFFFFF.
+ ].
+ aMorphicAlarm sequenceNumber: sequenceNumber.
+ super add: aMorphicAlarm.
+
+ "If we doubt our sanity..."
+ false ifTrue: [
+ self isValidHeap ifFalse: [self error: 'not a valid heap!!!!!!'].
+ ].
+ ^aMorphicAlarm!
Item was added:
+ ----- Method: MorphicAlarmQueue>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ sequenceNumber := 0.!
Item was added:
+ ----- Method: MorphicAlarmQueue>>isValidHeap (in category 'private') -----
+ isValidHeap
+ "Verify the correctness of the heap"
+ 2 to: tally do:[:i|
+ (self sorts: (array at: i // 2) before: (array at: i)) ifFalse:[^false].
+ ].
+ ^true!
Item was added:
+ ----- Method: MorphicAlarmQueue>>mutex (in category 'accessing') -----
+ mutex
+ ^mutex ifNil: [mutex := Mutex new]!
Item was added:
+ ----- Method: MorphicAlarmQueue>>sorts:before: (in category 'comparing') -----
+ sorts: alarmA before: alarmB
+ alarmA scheduledTime = alarmB scheduledTime
+ ifFalse:[^alarmA scheduledTime < alarmB scheduledTime].
+ alarmA sequenceNumber = alarmB sequenceNumber
+ ifFalse:[^alarmA sequenceNumber < alarmB sequenceNumber].
+ ^self error: 'These alarms run at the same time'!
Item was added:
+ Object subclass: #MorphicEvent
+ instanceVariableNames: 'timeStamp source'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
+
+ !MorphicEvent commentStamp: '<historical>' prior: 0!
+ This class represents the base for all events.
+
+ Instance variables:
+ stamp <Integer> The millisecond clock time stamp (based on Time millisecondClock)
+ source <Hand | nil> If non-nil the hand that generated the event.!
Item was added:
+ ----- Method: MorphicEvent class>>convertObsolete: (in category 'instance creation') -----
+ convertObsolete: anEvent
+ "ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
+ | type cursorPoint buttons keyValue sourceHand |
+ type := anEvent type.
+ cursorPoint := anEvent cursorPoint.
+ buttons := anEvent buttons.
+ keyValue := anEvent keyValue.
+ sourceHand := anEvent hand.
+ type == #mouseMove ifTrue:[
+ ^MouseMoveEvent new
+ setType: #mouseMove
+ startPoint: cursorPoint
+ endPoint: cursorPoint
+ trail: #()
+ buttons: buttons
+ hand: sourceHand
+ stamp: nil].
+ (type == #mouseDown) | (type == #mouseUp) ifTrue:[
+ ^MouseButtonEvent new
+ setType: type
+ position: cursorPoint
+ which: 0
+ buttons: buttons
+ hand: sourceHand
+ stamp: nil].
+ (type == #keystroke) | (type == #keyDown) | (type == #keyUp) ifTrue:[
+ ^KeyboardEvent new
+ setType: type
+ buttons: buttons
+ position: cursorPoint
+ keyValue: keyValue
+ hand: sourceHand
+ stamp: nil].
+ ^nil!
Item was added:
+ ----- Method: MorphicEvent class>>readFrom: (in category 'instance creation') -----
+ readFrom: aStream
+ "Read a MorphicEvent from the given stream."
+ | typeString |
+ typeString := String streamContents:
+ [:s | | c | [(c := aStream next) isLetter] whileTrue: [s nextPut: c]].
+ typeString = 'mouseMove' ifTrue:[^MouseMoveEvent type: #mouseMove readFrom: aStream].
+ typeString = 'mouseDown' ifTrue:[^MouseButtonEvent type: #mouseDown readFrom: aStream].
+ typeString = 'mouseUp' ifTrue:[^MouseButtonEvent type: #mouseUp readFrom: aStream].
+
+ typeString = 'keystroke' ifTrue:[^KeyboardEvent type: #keystroke readFrom: aStream].
+ typeString = 'keyDown' ifTrue:[^KeyboardEvent type: #keyDown readFrom: aStream].
+ typeString = 'keyUp' ifTrue:[^KeyboardEvent type: #keyUp readFrom: aStream].
+
+ typeString = 'mouseOver' ifTrue:[^MouseEvent type: #mouseOver readFrom: aStream].
+ typeString = 'mouseEnter' ifTrue:[^MouseEvent type: #mouseEnter readFrom: aStream].
+ typeString = 'mouseLeave' ifTrue:[^MouseEvent type: #mouseLeave readFrom: aStream].
+
+ typeString = 'unknown' ifTrue:[^MorphicUnknownEvent type: #unknown readFrom: aStream].
+
+ ^nil
+ !
Item was added:
+ ----- Method: MorphicEvent class>>readFromObsolete: (in category 'instance creation') -----
+ readFromObsolete: aStream
+ "Read one of those old and now obsolete events from the stream"
+ | type x y buttons keyValue typeString |
+ typeString := String streamContents:
+ [:s | | c | [(c := aStream next) isLetter] whileTrue: [s nextPut: c]].
+ typeString = 'mouseMove'
+ ifTrue: [type := #mouseMove "fast treatment of common case"]
+ ifFalse: [type := typeString asSymbol].
+
+ x := Integer readFrom: aStream.
+ aStream skip: 1.
+ y := Integer readFrom: aStream.
+ aStream skip: 1.
+
+ buttons := Integer readFrom: aStream.
+ aStream skip: 1.
+
+ keyValue := Integer readFrom: aStream.
+
+ typeString = 'mouseMove' ifTrue:[
+ ^MouseMoveEvent new
+ setType: #mouseMove
+ startPoint: x at y
+ endPoint: x at y
+ trail: #()
+ buttons: buttons
+ hand: nil
+ stamp: nil].
+ (typeString = 'mouseDown') | (typeString = 'mouseUp') ifTrue:[
+ ^MouseButtonEvent new
+ setType: type
+ position: x at y
+ which: 0
+ buttons: buttons
+ hand: nil
+ stamp: nil].
+ (typeString = 'keystroke') | (typeString = 'keyDown') | (typeString = 'keyUp') ifTrue:[
+ ^KeyboardEvent new
+ setType: type
+ buttons: buttons
+ position: x at y
+ keyValue: keyValue
+ hand: nil
+ stamp: nil].
+
+ ^nil!
Item was added:
+ ----- Method: MorphicEvent class>>type:readFrom: (in category 'instance creation') -----
+ type: eventType readFrom: aStream
+ ^self new type: eventType readFrom: aStream!
Item was added:
+ ----- Method: MorphicEvent>>= (in category 'comparing') -----
+ = anEvent
+ anEvent isMorphicEvent ifFalse:[^false].
+ ^self type = anEvent type!
Item was added:
+ ----- Method: MorphicEvent>>convertOctober2000:using: (in category 'object fileIn') -----
+ convertOctober2000: varDict using: smartRefStrm
+ "ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
+ "These are going away #('type' 'cursorPoint' 'buttons' 'keyValue' 'sourceHand'). Possibly store their info in another variable?"
+ | type cursorPoint buttons keyValue sourceHand |
+ type := varDict at: 'type'.
+ cursorPoint := varDict at: 'cursorPoint'.
+ buttons := varDict at: 'buttons'.
+ keyValue := varDict at: 'keyValue'.
+ sourceHand := varDict at: 'sourceHand'.
+ type == #mouseMove ifTrue:[
+ ^MouseMoveEvent new
+ setType: #mouseMove
+ startPoint: cursorPoint
+ endPoint: cursorPoint
+ trail: #()
+ buttons: buttons
+ hand: sourceHand
+ stamp: nil].
+ (type == #mouseDown) | (type == #mouseUp) ifTrue:[
+ ^MouseButtonEvent new
+ setType: type
+ position: cursorPoint
+ which: 0
+ buttons: buttons
+ hand: sourceHand
+ stamp: nil].
+ (type == #keystroke) | (type == #keyDown) | (type == #keyUp) ifTrue:[
+ ^KeyboardEvent new
+ setType: type
+ buttons: buttons
+ position: cursorPoint
+ keyValue: keyValue
+ hand: sourceHand
+ stamp: nil].
+ "All others will be handled there"
+ ^MorphicUnknownEvent new!
Item was added:
+ ----- Method: MorphicEvent>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+
+
+ "ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
+ varDict at: 'cursorPoint' ifPresent: [ :x | | answer |
+ answer := self convertOctober2000: varDict using: smartRefStrm.
+ varDict removeKey: 'cursorPoint'. "avoid doing this again"
+ ^answer
+ ].
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+
+ !
Item was added:
+ ----- Method: MorphicEvent>>copyHandlerState: (in category 'initialize') -----
+ copyHandlerState: anEvent
+ "Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
+ !
Item was added:
+ ----- Method: MorphicEvent>>cursorPoint (in category 'accessing') -----
+ cursorPoint
+ "Backward compatibility. Use #position instead"
+ ^ self position!
Item was added:
+ ----- Method: MorphicEvent>>hand (in category 'accessing') -----
+ hand
+ "Return the source that generated the event"
+ ^source!
Item was added:
+ ----- Method: MorphicEvent>>hash (in category 'comparing') -----
+ hash
+ ^self type hash!
Item was added:
+ ----- Method: MorphicEvent>>isDraggingEvent (in category 'testing') -----
+ isDraggingEvent
+ ^false!
Item was added:
+ ----- Method: MorphicEvent>>isDropEvent (in category 'testing') -----
+ isDropEvent
+ ^false!
Item was added:
+ ----- Method: MorphicEvent>>isKeyboard (in category 'testing') -----
+ isKeyboard
+ ^false!
Item was added:
+ ----- Method: MorphicEvent>>isKeystroke (in category 'testing') -----
+ isKeystroke
+ ^false!
Item was added:
+ ----- Method: MorphicEvent>>isMorphicEvent (in category 'testing') -----
+ isMorphicEvent
+ ^true!
Item was added:
+ ----- Method: MorphicEvent>>isMouse (in category 'testing') -----
+ isMouse
+ ^false!
Item was added:
+ ----- Method: MorphicEvent>>isMouseOver (in category 'testing') -----
+ isMouseOver
+ ^self type == #mouseOver!
Item was added:
+ ----- Method: MorphicEvent>>isWindowEvent (in category 'testing') -----
+ isWindowEvent
+ ^false!
Item was added:
+ ----- Method: MorphicEvent>>position (in category 'accessing') -----
+ position
+ "Since cursorPoint is defined and refers to position it should be defined
+ here as well"
+ ^ self subclassResponsibility!
Item was added:
+ ----- Method: MorphicEvent>>resetHandlerFields (in category 'initialize') -----
+ resetHandlerFields
+ "Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"!
Item was added:
+ ----- Method: MorphicEvent>>sentTo: (in category 'dispatching') -----
+ sentTo: anObject
+ "Dispatch the receiver into anObject"
+ ^anObject handleUnknownEvent: self!
Item was added:
+ ----- Method: MorphicEvent>>setHand: (in category 'private') -----
+ setHand: aHand
+ source := aHand!
Item was added:
+ ----- Method: MorphicEvent>>setTimeStamp: (in category 'private') -----
+ setTimeStamp: stamp
+ timeStamp := stamp.!
Item was added:
+ ----- Method: MorphicEvent>>timeStamp (in category 'accessing') -----
+ timeStamp
+ "Return the millisecond clock value at which the event was generated"
+ ^timeStamp ifNil:[timeStamp := Time millisecondClockValue]!
Item was added:
+ ----- Method: MorphicEvent>>transformedBy: (in category 'transforming') -----
+ transformedBy: aMorphicTransform
+ "Return the receiver transformed by the given transform into a local coordinate system."
+ !
Item was added:
+ ----- Method: MorphicEvent>>type (in category 'accessing') -----
+ type
+ "Return a symbol indicating the type this event."
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: MorphicEvent>>type:readFrom: (in category 'initialize') -----
+ type: eventType readFrom: aStream
+ "Read a MorphicEvent from the given stream."
+ !
Item was added:
+ ----- Method: MorphicEvent>>wasHandled (in category 'accessing') -----
+ wasHandled
+ "Return true if this event was handled. May be ignored for some types of events."
+ ^false!
Item was added:
+ ----- Method: MorphicEvent>>wasHandled: (in category 'accessing') -----
+ wasHandled: aBool
+ "Determine if this event was handled. May be ignored for some types of events."!
Item was added:
+ Object subclass: #MorphicEventDispatcher
+ instanceVariableNames: 'lastType lastDispatch'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
+
+ !MorphicEventDispatcher commentStamp: '<historical>' prior: 0!
+ The class represents a strategy for dispatching events to some immediate child of a morph. It is used by morphs to delegate the somewhat complex action of dispatching events accurately. !
Item was added:
+ ----- Method: MorphicEventDispatcher>>dispatchDefault:with: (in category 'dispatching') -----
+ dispatchDefault: anEvent with: aMorph
+ "Dispatch the given event. The event will be passed to the front-most visible submorph that contains the position wrt. to the event."
+ | localEvt index child morphs inside |
+ "See if we're fully outside aMorphs bounds"
+ (aMorph fullBounds containsPoint: anEvent position) ifFalse:[^#rejected]. "outside"
+ "Traverse children"
+ index := 1.
+ morphs := aMorph submorphs.
+ inside := false.
+ [index <= morphs size] whileTrue:[
+ child := morphs at: index.
+ localEvt := anEvent transformedBy: (child transformedFrom: aMorph).
+ (child processEvent: localEvt using: self) == #rejected ifFalse:[
+ "Not rejected. The event was in some submorph of the receiver"
+ inside := true.
+ localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt].
+ index := morphs size. "break"
+ ].
+ index := index + 1.
+ ].
+
+ "Check for being inside the receiver"
+ inside ifFalse:[inside := aMorph containsPoint: anEvent position event: anEvent].
+ inside ifTrue:[^aMorph handleEvent: anEvent].
+ ^#rejected
+ !
Item was added:
+ ----- Method: MorphicEventDispatcher>>dispatchDropEvent:with: (in category 'dispatching') -----
+ dispatchDropEvent: anEvent with: aMorph
+ "Find the appropriate receiver for the event and let it handle it. The dispatch is similar to the default dispatch with one difference: Morphs are given the chance to reject an entire drop operation. If the operation is rejected, no drop will be executed."
+ | inside index morphs child localEvt |
+ "Try to get out quickly"
+ (aMorph fullBounds containsPoint: anEvent cursorPoint)
+ ifFalse:[^#rejected].
+ "Give aMorph a chance to repel the dropping morph"
+ aMorph rejectDropEvent: anEvent.
+ anEvent wasHandled ifTrue:[^self].
+
+ "Go looking if any of our submorphs wants it"
+ index := 1.
+ inside := false.
+ morphs := aMorph submorphs.
+ [index <= morphs size] whileTrue:[
+ child := morphs at: index.
+ localEvt := anEvent transformedBy: (child transformedFrom: aMorph).
+ (child processEvent: localEvt using: self) == #rejected ifFalse:[
+ localEvt wasHandled ifTrue:[^anEvent wasHandled: true]. "done"
+ inside := true.
+ index := morphs size]. "break"
+ index := index + 1.
+ ].
+
+ inside ifFalse:[inside := aMorph containsPoint: anEvent cursorPoint event: anEvent].
+ inside ifTrue:[^aMorph handleEvent: anEvent].
+ ^#rejected!
Item was added:
+ ----- Method: MorphicEventDispatcher>>dispatchEvent:with: (in category 'dispatching') -----
+ dispatchEvent: anEvent with: aMorph
+ "Dispatch the given event for a morph that has chosen the receiver to dispatch its events. The method implements a shortcut for repeated dispatches of events using the same dispatcher."
+ anEvent type == lastType ifTrue:[^self perform: lastDispatch with: anEvent with: aMorph].
+ "Otherwise classify"
+ lastType := anEvent type.
+ anEvent isMouse ifTrue:[
+ anEvent isMouseDown ifTrue:[
+ lastDispatch := #dispatchMouseDown:with:.
+ ^self dispatchMouseDown: anEvent with: aMorph]].
+ anEvent type == #dropEvent ifTrue:[
+ lastDispatch := #dispatchDropEvent:with:.
+ ^self dispatchDropEvent: anEvent with: aMorph].
+ anEvent isWindowEvent ifTrue:[
+ lastDispatch := #dispatchWindowEvent:with:.
+ ^self dispatchWindowEvent: anEvent with: aMorph].
+ lastDispatch := #dispatchDefault:with:.
+ ^self dispatchDefault: anEvent with: aMorph!
Item was added:
+ ----- Method: MorphicEventDispatcher>>dispatchMouseDown:with: (in category 'dispatching') -----
+ dispatchMouseDown: anEvent with: aMorph
+ "Find the appropriate receiver for the event and let it handle it. Default rules:
+ * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event.
+ * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is.
+ * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed.
+ * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event.
+ "
+ | globalPt localEvt index child morphs handler inside lastHandler |
+ "Try to get out quickly"
+ globalPt := anEvent cursorPoint.
+ (aMorph fullBounds containsPoint: globalPt) ifFalse:[^#rejected].
+
+ "Install the prospective handler for the receiver"
+ lastHandler := anEvent handler. "in case the mouse wasn't even in the receiver"
+ handler := aMorph handlerForMouseDown: anEvent.
+ handler ifNotNil:[anEvent handler: handler].
+
+ "Now give our submorphs a chance to handle the event"
+ index := 1.
+ morphs := aMorph submorphs.
+ [index <= morphs size] whileTrue:[
+ child := morphs at: index.
+ localEvt := anEvent transformedBy: (child transformedFrom: aMorph).
+ (child processEvent: localEvt using: self) == #rejected ifFalse:[
+ "Some child did contain the point so we're part of the top-most chain."
+ inside := false.
+ localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt].
+ index := morphs size].
+ index := index + 1.
+ ].
+
+ (inside == false or:[aMorph containsPoint: anEvent cursorPoint event: anEvent]) ifTrue:[
+ "Receiver is in the top-most unlocked, visible chain."
+ handler ifNotNil:[handler handleEvent: anEvent].
+ "Note: Re-installing the handler is not really necessary but good style."
+ anEvent handler: lastHandler.
+ ^self
+ ].
+ "Mouse was not on receiver nor any of its children"
+ anEvent handler: lastHandler.
+ ^#rejected!
Item was added:
+ ----- Method: MorphicEventDispatcher>>dispatchWindowEvent:with: (in category 'dispatching') -----
+ dispatchWindowEvent: anEvent with: aMorph
+ "Host window events do not have a position and are only dispatched to the World"
+ aMorph isWorldMorph ifFalse: [^#rejected].
+ anEvent wasHandled ifTrue:[^self].
+ ^aMorph handleEvent: anEvent!
Item was added:
+ BorderedMorph subclass: #MorphicModel
+ instanceVariableNames: 'model slotName open'
+ classVariableNames: 'TimeOfError'
+ poolDictionaries: ''
+ category: 'Morphic-Kernel'!
+ MorphicModel class
+ instanceVariableNames: 'prototype'!
+
+ !MorphicModel commentStamp: '<historical>' prior: 0!
+ MorphicModels are used to represent structures with state and behavior as well as graphical structure. A morphicModel is usually the root of a morphic tree depicting its appearance. The tree is constructed concretely by adding its consituent morphs to a world.
+
+ When a part is named in a world, it is given a new slot in the model. When a part is sensitized, it is named, and a set of mouse-driven methods is also generated in the model. These may be edited to induce particular behavior. When a variable is added through the morphic world, it is given a slot in the model, along with a set of access methods.
+
+ In addition for public variables (and this is the default for now), methods are generated and called in any outer model in which this model gets embedded, thus propagating variable changes outward.!
+ MorphicModel class
+ instanceVariableNames: 'prototype'!
Item was added:
+ ----- Method: MorphicModel class>>acceptsLoggingOfCompilation (in category 'compiling') -----
+ acceptsLoggingOfCompilation
+ "Dont log sources for my automatically-generated subclasses. Can easily switch this back when it comes to deal with Versions, etc."
+
+ ^ self == MorphicModel or: [(name last isDigit) not]!
Item was added:
+ ----- Method: MorphicModel class>>categoryForSubclasses (in category 'compilation') -----
+ categoryForSubclasses
+ ^ 'Morphic-Models'!
Item was added:
+ ----- Method: MorphicModel class>>chooseNewName (in category 'compilation') -----
+ chooseNewName
+ "Choose a new name for the receiver, persisting until an acceptable name is provided or until the existing name is resubmitted"
+
+ | oldName newName |
+ oldName := self name.
+ [newName := (UIManager default request: 'Please give this Model a name'
+ initialAnswer: oldName) asSymbol.
+ newName = oldName ifTrue: [^ self].
+ Smalltalk includesKey: newName]
+ whileTrue:
+ [self inform: 'Sorry, that name is already in use.'].
+ self rename: newName.!
Item was added:
+ ----- Method: MorphicModel class>>compileAccessorsFor: (in category 'compilation') -----
+ compileAccessorsFor: varName
+ self compile: (
+ '&var
+ "Return the value of &var"
+ ^ &var'
+ copyReplaceAll: '&var' with: varName)
+ classified: 'public access' notifying: nil.
+ self compile: (
+ '&varPut: newValue
+ "Assign newValue to &var.
+ Add code below to update related graphics appropriately..."
+
+ &var := newValue.'
+ copyReplaceAll: '&var' with: varName)
+ classified: 'public access' notifying: nil.
+ self compile: (
+ '&var: newValue
+ "Assigns newValue to &var and updates owner"
+ &var := newValue.
+ self propagate: &var as: ''&var:'''
+ copyReplaceAll: '&var' with: varName)
+ classified: 'private - propagation' notifying: nil.
+ !
Item was added:
+ ----- Method: MorphicModel class>>compilePropagationForVarName:slotName: (in category 'compilation') -----
+ compilePropagationForVarName: varName slotName: slotName
+ self compile: ((
+ '&slot&var: newValue
+ "The value of &var in &slot has changed to newValue.
+ This value can be read elsewhere in code with
+ &slot &var
+ and it can be stored into with
+ &slot &varPut: someValue"
+
+ "Add code for appropriate response here..."'
+ copyReplaceAll: '&var' with: varName)
+ copyReplaceAll: '&slot' with: slotName)
+ classified: 'input events' notifying: nil.
+ !
Item was added:
+ ----- Method: MorphicModel class>>hasPrototype (in category 'queries') -----
+ hasPrototype
+ "Return true if there is a prototype for this morph."
+
+ ^ prototype ~~ nil
+ !
Item was added:
+ ----- Method: MorphicModel class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ "Only include Models that are appropriate"
+ ^ false!
Item was added:
+ ----- Method: MorphicModel class>>new (in category 'instance creation') -----
+ new
+ "Return a copy of the prototype, if there is one.
+ Otherwise create a new instance normally."
+
+ self hasPrototype ifTrue: [^ prototype veryDeepCopy].
+ ^ super new
+ !
Item was added:
+ ----- Method: MorphicModel class>>newBounds:model:slotName: (in category 'instance creation') -----
+ newBounds: bounds model: thang slotName: nameOfThisPart
+ ^ (super new model: thang slotName: nameOfThisPart)
+ newBounds: bounds!
Item was added:
+ ----- Method: MorphicModel class>>newSubclass (in category 'subclass creation') -----
+ newSubclass
+ | i className |
+ i := 1.
+ [className := (self name , i printString) asSymbol.
+ Smalltalk includesKey: className]
+ whileTrue: [i := i + 1].
+
+ ^ self subclass: className
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Models'!
Item was added:
+ ----- Method: MorphicModel class>>officialClass (in category 'testing') -----
+ officialClass
+ "We want to make a new instance of the receiver, which is a subclass of MorphicModel. Answer who to make a new subclass of. Also used to tell if a given class is a UniClass, existing only for its single instance."
+
+ ^ self name last isDigit ifTrue: [MorphicModel] ifFalse: [self]
+ "MorphicModel7 can not have subclasses, but Slider and SystemWindow may"!
Item was added:
+ ----- Method: MorphicModel class>>prototype (in category 'prototype access') -----
+ prototype
+ "Return the prototype for this morph."
+
+ ^ prototype
+ !
Item was added:
+ ----- Method: MorphicModel class>>prototype: (in category 'prototype access') -----
+ prototype: aMorph
+ "Store a copy of the given morph as a prototype to be copied to make new instances."
+
+ aMorph ifNil: [prototype := nil. ^ self].
+
+ prototype := aMorph veryDeepCopy.
+ (prototype isMorphicModel) ifTrue:
+ [prototype model: nil slotName: nil].
+ !
Item was added:
+ ----- Method: MorphicModel class>>removeUninstantiatedModels (in category 'housekeeping') -----
+ removeUninstantiatedModels
+ "With the user's permission, remove the classes of any models that have neither instances nor subclasses."
+ "MorphicModel removeUninstantiatedModels"
+
+ | candidatesForRemoval |
+ Smalltalk garbageCollect.
+ candidatesForRemoval :=
+ MorphicModel subclasses select: [:c |
+ (c instanceCount = 0) and: [c subclasses size = 0]].
+ candidatesForRemoval do: [:c | | ok |
+ ok := self confirm: 'Are you certain that you
+ want to delete the class ', c name, '?'.
+ ok ifTrue: [c removeFromSystem]].
+ !
Item was added:
+ ----- Method: MorphicModel class>>wantsChangeSetLogging (in category 'compiling') -----
+ wantsChangeSetLogging
+ "Log changes for MorphicModel itself and for things like PlayWithMe2, but not for automatically-created subclasses like MorphicModel1, MorphicModel2, etc."
+
+ ^ self == MorphicModel or:
+ [(self class name beginsWith: 'Morphic') not]!
Item was added:
+ ----- Method: MorphicModel>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ model ifNotNil: [model addModelMenuItemsTo: aCustomMenu forMorph: self hand: aHandMorph].
+ self isOpen ifTrue: [aCustomMenu add: 'close editing' translated action: #closeToEdits]
+ ifFalse: [aCustomMenu add: 'open editing' translated action: #openToEdits].
+ !
Item was added:
+ ----- Method: MorphicModel>>addPartNameLike:withValue: (in category 'compilation') -----
+ addPartNameLike: className withValue: aMorph
+ | otherNames i default partName stem |
+ stem := className first asLowercase asString , className allButFirst.
+ otherNames := self class allInstVarNames.
+ i := 1.
+ [otherNames includes: (default := stem, i printString)]
+ whileTrue: [i := i + 1].
+ partName := UIManager default
+ request: 'Please give this part a name'
+ initialAnswer: default.
+ (otherNames includes: partName)
+ ifTrue: [self inform: 'Sorry, that name is already used'. ^ nil].
+ self class addInstVarName: partName.
+ self instVarAt: self class instSize put: aMorph. "Assumes added as last field"
+ ^ partName!
Item was added:
+ ----- Method: MorphicModel>>allKnownNames (in category 'submorphs-accessing') -----
+ allKnownNames
+ "Return a list of all known names based on the scope of the receiver. If the receiver is a member of a uniclass, incorporate the original 1997 logic that queries the known names of the values of all the instance variables."
+
+ | superNames |
+ superNames := super allKnownNames. "gather them from submorph tree"
+ ^self belongsToUniClass
+ ifTrue:
+ [superNames , (self instanceVariableValues
+ select: [:e | e notNil and: [e knownName notNil]]
+ thenCollect: [:e | e knownName])]
+ ifFalse: [superNames]!
Item was added:
+ ----- Method: MorphicModel>>allowSubmorphExtraction (in category 'drag and drop') -----
+ allowSubmorphExtraction
+ ^ self isOpen
+ !
Item was added:
+ ----- Method: MorphicModel>>charactersOccluded (in category 'geometry') -----
+ charactersOccluded
+ "Subclasses override as necessary to keep smart-splitters balanced."
+ ^ 0!
Item was added:
+ ----- Method: MorphicModel>>choosePartName (in category 'naming') -----
+ choosePartName
+ "When I am renamed, get a slot, make default methods, move any existing methods. ** Does not clean up old inst var name or methods** "
+
+ | old |
+ old := slotName.
+ super choosePartName.
+ slotName ifNil: [^self]. "user chose bad slot name"
+ self model: self world model slotName: slotName.
+ old isNil
+ ifTrue: [self compilePropagationMethods]
+ ifFalse: [self copySlotMethodsFrom: old]
+ "old ones not erased!!"!
Item was added:
+ ----- Method: MorphicModel>>closeToEdits (in category 'menu') -----
+ closeToEdits
+ "Disable this morph's ability to add and remove morphs via drag-n-drop."
+
+ open := false
+ !
Item was added:
+ ----- Method: MorphicModel>>compileAccessForSlot: (in category 'compilation') -----
+ compileAccessForSlot: aSlotName
+ "Write the method to get at this inst var. "
+ "Instead call the right thing to make this happen?"
+
+ | s |
+ s := WriteStream on: (String new: 2000).
+ s nextPutAll: aSlotName; cr; tab; nextPutAll: '^', aSlotName.
+ self class
+ compile: s contents
+ classified: 'public access'
+ notifying: nil.
+ !
Item was added:
+ ----- Method: MorphicModel>>compilePropagationMethods (in category 'compilation') -----
+ compilePropagationMethods
+
+ (self class organization listAtCategoryNamed: 'private - propagation' asSymbol)
+ do: [:sel | | varName |
+ varName := sel allButLast.
+ model class compilePropagationForVarName: varName slotName: slotName]!
Item was added:
+ ----- Method: MorphicModel>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ Color yellow!
Item was added:
+ ----- Method: MorphicModel>>defaultBounds (in category 'initialization') -----
+ defaultBounds
+ "answer the default bounds for the receiver"
+ ^ 0 @ 0 corner: 200 @ 100!
Item was added:
+ ----- Method: MorphicModel>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color transparent!
Item was added:
+ ----- Method: MorphicModel>>delete (in category 'submorphs-add/remove') -----
+ delete
+ (model isMorphicModel) ifFalse: [^super delete].
+ slotName ifNotNil:
+ [(UIManager default confirm: 'Shall I remove the slot ' , slotName
+ , '
+ along with all associated methods?')
+ ifTrue:
+ [(model class selectors select: [:s | s beginsWith: slotName])
+ do: [:s | model class removeSelector: s].
+ (model class instVarNames includes: slotName)
+ ifTrue: [model class removeInstVarName: slotName]]
+ ifFalse:
+ [(UIManager default
+ confirm: '...but should I at least dismiss this morph?
+ [choose no to leave everything unchanged]')
+ ifFalse: [^self]]].
+ super delete!
Item was added:
+ ----- Method: MorphicModel>>duplicate:from: (in category 'initialization') -----
+ duplicate: newGuy from: oldGuy
+ "oldGuy has just been duplicated and will stay in this world. Make sure all the MorphicModel requirements are carried out for the copy. Ask user to rename it. "
+
+ newGuy installModelIn: oldGuy world.
+ newGuy copySlotMethodsFrom: oldGuy slotName.!
Item was added:
+ ----- Method: MorphicModel>>initString (in category 'printing') -----
+ initString
+
+ ^ String streamContents:
+ [:s | s nextPutAll: self class name;
+ nextPutAll: ' newBounds: (';
+ print: bounds;
+ nextPutAll: ') model: self slotName: ';
+ print: slotName]!
Item was added:
+ ----- Method: MorphicModel>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ open := false!
Item was added:
+ ----- Method: MorphicModel>>installModelIn: (in category 'debug and other') -----
+ installModelIn: aWorld
+
+ self wantsSlot ifFalse: [^ self]. "No real need to install"
+ slotName := aWorld model addPartNameLike: self class name withValue: self.
+ slotName ifNil: [^ self]. "user chose bad slot name"
+ self model: aWorld model slotName: slotName.
+ self compilePropagationMethods.
+ aWorld model compileAccessForSlot: slotName.
+ !
Item was added:
+ ----- Method: MorphicModel>>isMorphicModel (in category 'classification') -----
+ isMorphicModel
+ ^true!
Item was added:
+ ----- Method: MorphicModel>>isOpen (in category 'drag and drop') -----
+ isOpen
+ "Support drag/drop and other edits."
+ ^ open!
Item was added:
+ ----- Method: MorphicModel>>model (in category 'accessing') -----
+ model
+ ^ model!
Item was added:
+ ----- Method: MorphicModel>>model: (in category 'initialization') -----
+ model: anObject
+ "Set my model and make me me a dependent of the given object."
+
+ model ifNotNil: [model removeDependent: self].
+ anObject ifNotNil: [anObject addDependent: self].
+ model := anObject.
+ !
Item was added:
+ ----- Method: MorphicModel>>model:slotName: (in category 'initialization') -----
+ model: thang slotName: nameOfThisPart
+ model := thang.
+ slotName := nameOfThisPart.
+ open := false.!
Item was added:
+ ----- Method: MorphicModel>>modelOrNil (in category 'accessing') -----
+ modelOrNil
+ ^ model!
Item was added:
+ ----- Method: MorphicModel>>nameFor: (in category 'compilation') -----
+ nameFor: aMorph
+ "Return the name of the slot containing the given morph or nil if that morph has not been named."
+
+ | allNames start |
+ allNames := self class allInstVarNames.
+ start := MorphicModel allInstVarNames size + 1.
+ start to: allNames size do: [:i |
+ (self instVarAt: i) == aMorph ifTrue: [^ allNames at: i]].
+ ^ nil
+ !
Item was added:
+ ----- Method: MorphicModel>>newBounds: (in category 'geometry') -----
+ newBounds: newBounds
+ self bounds: newBounds!
Item was added:
+ ----- Method: MorphicModel>>openToEdits (in category 'menu') -----
+ openToEdits
+ "Enable this morph's ability to add and remove morphs via drag-n-drop."
+
+ open := true
+ !
Item was added:
+ ----- Method: MorphicModel>>propagate:as: (in category 'compilation') -----
+ propagate: value as: partStoreSelector
+ model ifNil: [^ self].
+ "
+ Later we can cache this for more speed as follows...
+ (partName == cachedPartName and: [slotName == cachedSlotName])
+ ifFalse: [cachedPartName := partName.
+ cachedSlotName := slotName.
+ cachedStoreSelector := (slotName , partStoreSelector) asSymbol].
+ model perform: cachedStoreSelector with: value].
+ "
+ model perform: (self slotSelectorFor: partStoreSelector) with: value!
Item was added:
+ ----- Method: MorphicModel>>recomputeBounds (in category 'geometry') -----
+ recomputeBounds
+
+ | bnds |
+ bnds := submorphs first bounds.
+ bounds := bnds origin corner: bnds corner. "copy it!!"
+ fullBounds := nil.
+ bounds := self fullBounds.
+ !
Item was added:
+ ----- Method: MorphicModel>>releaseCachedState (in category 'caching') -----
+ releaseCachedState
+ "Release cached state of the receiver"
+
+ (model ~~ self and: [model respondsTo: #releaseCachedState]) ifTrue:
+ [model releaseCachedState].
+ super releaseCachedState!
Item was added:
+ ----- Method: MorphicModel>>removeAll (in category 'compilation') -----
+ removeAll
+ "Clear out all script methods and subpart instance variables in me. Start over."
+ "self removeAll"
+ "MorphicModel2 removeAll"
+
+ self class == MorphicModel ifTrue: [^ self]. "Must be a subclass!!"
+ self class removeCategory: 'scripts'.
+ self class instVarNames do: [:nn | self class removeInstVarName: nn].!
Item was added:
+ ----- Method: MorphicModel>>slotName (in category 'accessing') -----
+ slotName
+ ^ slotName!
Item was added:
+ ----- Method: MorphicModel>>slotSelectorFor: (in category 'compilation') -----
+ slotSelectorFor: selectorBody
+ | selector |
+ model ifNil: [^ nil].
+ "Make up selector from slotname if any"
+ selector := (slotName ifNil: [selectorBody]
+ ifNotNil: [slotName , selectorBody]) asSymbol.
+ (model canUnderstand: selector) ifFalse:
+ [self halt: 'Compiling a null response for ' , model class name , '>>' , selector].
+ ^ selector!
Item was added:
+ ----- Method: MorphicModel>>use:orMakeModelSelectorFor:in: (in category 'compilation') -----
+ use: cachedSelector orMakeModelSelectorFor: selectorBody in: selectorBlock
+ | selector |
+ model ifNil: [^ nil].
+ cachedSelector ifNil:
+ ["Make up selector from slotname if any"
+ selector := (slotName ifNil: [selectorBody]
+ ifNotNil: [slotName , selectorBody]) asSymbol.
+ (model class canUnderstand: selector) ifFalse:
+ [(self confirm: 'Shall I compile a null response for'
+ , Character cr asString
+ , model class name , '>>' , selector)
+ ifFalse: [self halt].
+ model class compile: (String streamContents:
+ [:s | selector keywords doWithIndex:
+ [:k :i | s nextPutAll: k , ' arg' , i printString].
+ s cr; nextPutAll: '"Automatically generated null response."'.
+ s cr; nextPutAll: '"Add code below for appropriate behavior..."'.])
+ classified: 'input events'
+ notifying: nil]]
+ ifNotNil:
+ [selector := cachedSelector].
+ ^ selectorBlock value: selector!
Item was added:
+ ----- Method: MorphicModel>>wantsSlot (in category 'accessing') -----
+ wantsSlot
+ "Override this default for models that want to be installed in theri model"
+ ^ false!
Item was added:
+ MorphicModel subclass: #MorphicModel1
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Models'!
Item was added:
+ MorphicModel subclass: #MorphicModel2
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Models'!
Item was added:
+ MorphicModel subclass: #MorphicModel3
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Models'!
Item was added:
+ Project subclass: #MorphicProject
+ instanceVariableNames: 'uiProcess'
+ classVariableNames: 'DefaultFill'
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !MorphicProject commentStamp: 'dtl 7/13/2013 15:40' prior: 0!
+ An MorphicProject is a project with a Morphic user interface. Its world is a PasteUpMorph, and its UI manager is a MorphicUIManager. It uses a MorphicToolBuilder to create the views for various tools. It has a single uiProcess for its world, and Morph updates and user interaction occur in the context of that UI process.
+ !
Item was added:
+ ----- Method: MorphicProject class>>compileNewDefaultBackgroundFrom: (in category 'utilities') -----
+ compileNewDefaultBackgroundFrom: aForm
+ "Compile a new #defaultBackgroundForm method in this class-side which uses aForm as the background."
+ | formStream base64 |
+ formStream := ByteArray new writeStream.
+ PNGReadWriter
+ putForm: aForm
+ onStream: formStream.
+ base64 := formStream base64Encoded.
+ self class
+ compile:
+ (String streamContents:
+ [ : stream | stream
+ nextPutAll: 'defaultBackgroundForm
+ ^ Form fromBinaryStream: ' ;
+ nextPut: $' ;
+ nextPutAll: base64 ;
+ nextPut: $' ;
+ nextPutAll: ' base64Decoded asByteArray readStream' ])
+ classified: 'class initialization'!
Item was added:
+ ----- Method: MorphicProject class>>convertOldProjects (in category 'class initialization') -----
+ convertOldProjects
+ "Convert older Morphic projects to be MorphicProjects"
+ Project allInstancesDo:[:p|
+ p isMorphic ifTrue:[p primitiveChangeClassTo: self basicNew].
+ ].!
Item was added:
+ ----- Method: MorphicProject class>>defaultBackgroundForm (in category 'class initialization') -----
+ defaultBackgroundForm
+ ^ Form fromBinaryStream: 'iVBORw0KGgoAAAANSUhEUgAAAGYAAABXCAYAAAD2+TBqAAAvWUlEQVR4Xl3d19ocRZKA4b7/
+ k72BPRqz45YBZkAIhDzyXkLe/0hIyOIlJEFtvdn9NbVzUE+XzYwMnxGR2audB+emR998OT1/
+ eWP66uH56fzFvdPFL/dP9786Oz1+cnl69uL69ODrC9PV61+M32s3jozj7Pk905Vrh6cjx/41
+ 3b57cjp24qNxfHnl4HTy9CfTmXOfjXd8d+7C59OtOyemC5f2jXtPnl0d7965d2p6/ebhuK+N
+ l9/dGv0fP/nxdP3m0enS5QOj/2+eXhnf+cZ72nTuOZjv3j893n/6/Np0+uyn04lTu6a3vz6e
+ btw6Nt758ef7072dM+N6mp5P3/1wZ8D09eNLY5za/uXt1+Mc/N5x/fPrr6Zvv789DrB6H4xg
+ gAP9Xr4y4+XhpenZ85vTo8dXxvH8xa3p60eXpxs3T0wvv70znb+wfzp1+rNx/9btU9O168em
+ na8uTO9+fTpdvXZ8evrs1vTrby+m23fOTtdvnJzevH06rQz68tVDAyAEevXLgzEowAPUYCDC
+ gP06IAAhDRjQAP7hp3vjW4h076dXO+PXtcM3COvdm7ePD2Q49IuIkInQEIg4+oN07foFI4J/
+ cfTD8T6EnzqzexAR0hDKN9rWpl/t+S5G8hwB3def7w998f7oz+G+dhHNe34PH/lgnGsPbPD1
+ 8NHFwWj6PnFy94zcowPZFy8dnI6f+GTcu37j+HT33tnp4KEPpiNHP5rOnts7I/70eNczBL1w
+ 8cBM1MvT/Z2L052756Zz5w+MA4FWkIsgqK9jiHvx7c3RucH4JTkOQBnc/oP/OxCxM0ube5/v
+ +9tW6gzEABHVwCEFYg0OYd68ezQ4DuFIjv78OhAQIRw48/sf7w64tI2wYP1tejo42fvu6d/h
+ G+/rw7UxQCb4SWTn/Wofco3Z2Pz6Vpv6NDYwuo5BtesaPJ5hxFevv55e//JoKymPv7k6JIUU
+ 3bt/btz76sHFQSTX3zy5Ns4ffv3l9MOPO9PNWyfHt965c/fMkKj7O+enFWAgCiCQBCgcaOAG
+ CyjXAPOewUA27j1w6L2h9gDrGQ4yaN8cPPzPcc9z77tGKARyrj0ExP0kVP9Hj/97DFrfuNU7
+ 7377ZisJpJg0aA9iIArnG4PvcT3m6D1wRSDnxqNNY/CNdl1ry3lE1iYVi3jgdy9V71v3++bF
+ y9vTk6fXhyRQZ5ANye5D+Okze8a9X948HhKCID/+9NVWxfnWd1Tb9z/cH4T88vLhaaVDg4Aw
+ qgdidWiQCIUAOAqXegY4nAnwCOI8AkOKdwGeunMvhOgLByMItZhK8qtPRPMLmdSW9xGJhILF
+ e6k+7aSeIJAkJwG+1Z8+PAe3AzOkumpnz96/bm0aiU+VOpI47xqfdzCQX31e+vLQdOXqkUEA
+ v9TZseO7hiQgwr797w0JgPxz5/eNe5BPoqg80oaoh7/417j/86uHg2ArnQLEAAwEgAaXqkAE
+ SAUYQDN8dLdrxh9HQS7k+Ta16L24MJVloFRA9kP7SRlVhsN96xqBIdm5A4zgdQ/htYEhEM89
+ /ZJasCAiVex975GoDHhEqn33MA+4tAcGDgC44cQ7SZ9z8PoGYUgF9YXznSMCVcWe+HUfotmZ
+ iPfFkX+Pc8QhHYjLBrFTvnd/pQPIgSQIMfhEF2JxfLrYu4DCVQZN7eBsBPKO57gbVxqAd1wj
+ Yh6S9iEZM7iG4O7pC/IMGCIREmLZJTBqE8LAmienT7DmPaXiwEtF+oXQCBuBMCBGADemQ6gM
+ f9+7N03PRh+pRn3pWxvsHZvANnz3/b0hDQjx9t2TgVzP2CBqy7Pu8dgQ0TVJSb0hEmnT3grA
+ AIMMiAgBiILziC1AcBIipGcNMIPoGkK4mJADeO9DoOfuaTfDm53SfoQMKQ5c7/AOO+YZafQM
+ MiGJpOYkcD4wC0bRvl/IdA/sCGKM2kwFudY+pvLrPc/AhpFSc6Sw77WNONqhKjHGyVOfDvUF
+ +VQT1YXzSQUXmTTxwrzD9vDGSAWb4pqj4JpKo+5I2SBM6sBgdARAg25+srQvCAdAv75LLRho
+ Rpi9yZbgWEjPWFMXuNdAEQ8hEZikOJqTaGfMEWYE4VxtuNYOIkCK8wgJDrAmnZANeZgu+6ZN
+ DNL8rDHlbGgDLAgNtlzk1LbrHCPX8DQckZkI3353d9p/4J8D+aSBywzhDirKNQkhTRBPUqg6
+ v5wbfWI4mgF8xrzSGQAyktmC9LxBxNWQBxhS4D4E4KBUzt79fx+cPYzizH3NGSBAewaE4BlX
+ 5/sO/GMMFsE/+fRP4x3tI1J6Pe8QnK4NArw5Ekk7+HLvfeM9/bI3kI443nUPIc1hfN8k0z3n
+ YE9t6RNTQZq2wap9v+Bn5HlbpIUEZPSn6eXWbpAYEuIgDe7lxemT5oAPMMIXLbHSgc4BD1BA
+ NbhsCATgUoNAOFzUNc5M1xtwkzCI0hEExY2Q7j5mgACSRcW57/AOhDdxRDT3SaM+89QQURvN
+ T/LM3POt++AAd3OpvDb3PNNmDKSvvDTIdu0cfDw2RCN1Dn0gGqIPJ2ImBgRzh83kzVVIAylC
+ JAd1Rl15F3GoOFKEOMZnDOFZ+9pdxRE8EhySl4IoXvAM8ZoHFBHAuQ7A7mzCOhp1jbDZnr4x
+ UIOJ6w3W+/olZc4Zds/i3AgAHjA4MvQITAVQScGkP3Ak0UUl3ANj3h04qNFgwxze8evbVGBT
+ CN/mAKXuaZHhyc7GnFcFyYhCPVFhPDH3HNSYZ0+f3RjzG+quOQu8ciJIJNwZP5ysiA6AAGLQ
+ BuIFSMBpGWWAp48BnHoKUYiIOyGzSEFc2aBIpf5SmzgTF2fsM876x0nNa0ICoqbj9QNBhYx8
+ q32I85z0M/7ew1xNCYxVH+BoVu9bttG34MIgfl2zk95rAr6MNhg7tcUFZvx/+vnBVmIg35wE
+ AUiPe94jKVQc6eGB6fvsec7Xvhn+2SO7d3JcD4kBQCqiiVaz/aFHN2JmsIAzcA36RYzEEQES
+ S+cRN98fgryL01OVBlygFLJiCm04RxQwQIjvC5bGQNoFm3ZJV0FOY6EKEYR05kW5/9nnf/l/
+ sTBjKAphXNpzUJFgKUaHyYobgkG7EMzG7N33v9Onn/11OACIcPTYx9Oez/8+JMrBFUYQaoxE
+ IVzOyrUb5pDwZjwXZmY5s57HQBLASE2eQXaCQS1+hkMyisTNd83sSY17TUghHOdRNdqjOryH
+ GBEn2+N58anUkL69bx5R7M59fVNB2tV3XhS4vI/zU1H6zGPTR6EbR+pW21vuX/Sx9OIKR/Us
+ b3TgbrYfJIUKY9hJCOmhvpyb37A9ucPmNe4hlv708eJbbdJAp2eh2D+ItGp2v5wJ8wpwLEQz
+ flSGI48p17TwB2TjpiaaGfBlhMAAER/nea4vA9YPAiIMVzibkEqkSnB9ahP3atN5HBfxU8vF
+ 41JBvEXvI3bf6pd0ZMNIlz6MmZQgrPe99+v0ZMBY3BBMGHgN+8th0BHDOeSToml6sSWAZ+41
+ 30FA0gU+hLl6/fAsoQfmPm/POCHJe6YVpBVugYDEGCEgl7hCsAYysoUkICbVkdsdQRAwdYj7
+ nCN+4Rnvl18pzFO+JvUDceDST6Ej50UU3EOovKtUTnG17E6SsPQUSxU0Z4oRSWHpBwQ0tuZT
+ BUqNyThdL3NAxlb4yrNUYzFGk/XwVf7JuAs1xVwYa1WcqnA3QAFX6MJ1EzEd5335JpEnJTou
+ 94KAfnUKCdkP1wUcM8DazkZRK+DwTuov9RND6DO1E7yeNe8xWAci9C1Gg5QiHODIPUbI5lik
+ jORAkva9i6BLt1tfpTIwa2pOP80Hs48OcGgHrM6L45UTyg7qrzFpY1WDzcghmWooxI9IgIPI
+ DHkRWggI6UVjC20UkfXMOWQXTXYOyNzjvCWE0AYkIaj+cXWBTW012cSJ5Wkg3T2z6OyUc4zl
+ uqBsMTDSlqueOobomNTYC+9E7IK68AFf2TLvglt/4CuSgSgFR7VvLNSfdzkx2qcS4UBbvtG3
+ Z65XkJdXgpJN1gAP+QaXmkAYwLlXnAvHpU6aFWckAevXwCDBt3GGftkyRCNdANUmLkIY7UE+
+ j6wJpsFRY/UdM3i3w7dlKyHHWPxqHxH0bazNi9IWzcvAAv5m4eCr7ybQxps3u4wjlp9yv4mq
+ PuCoEFfpdu2lthyuMyu+WwVsXofz8vsonlezdIUBXxaxuY3fIrjNSXRMPQBG54Vi0rG41DdJ
+ WSrS/f8MSHofrKmqJpTBWOq6eVLByCaFRR7AUS4o1apvB5XlfgQpgoAQmGM5+0eAvLOICKYm
+ w01K83oLDJcpTYoar/czDca9ys3UGNHENWUlHQYBoSWJTAgLzRRGB2xOAwDLEEYwHaZ2AKYd
+ 14ibKil/kl2hwspGNp8Amz48J4FJKXXgHilCNAMtDgaJeV5FxisOyaaVp6m/VBeVggmp2TxW
+ jFk6Qbuew4FzM3iqCCzOvQd2Y9KXMWlL28sohbaK9zm0sUqUSvuiKu6o8ALCigZDRiEKCNIR
+ MYUEDefbe7cij8InkA44wCa2f/jTf41JlYP/buZ75hw7NU/EznwyS9t7s/2gEj4a1w7n3vMO
+ F7NCEsiOifTF7mAiDBWsSW6RdO9ypd1DDAzjnZJuhV6aUpSqyLMqIJsnWPoidZVNLe7me3Cl
+ ZmmVXbv/OO7lAPlWu1vjny5OHLMFgKoipGQRoJ17D8dk5ByFxrVn0AZWcg3x3PdtDgYffucB
+ cT43CHT77omZqGzU9THpcl+Ywn0z4sdPvhwTspffsQfXtpPUose4z3iK50Fyqe+mAJBchBoM
+ nmEYxPF9EQvMBdkQZ44FwRWZxISl17PFudkRKfxqL0nxbXA1v4qRs32rQvsAK7RODKk1jacm
+ MugVahgEafK8erS4yjkA/Jba1SlEIE7zJO1B8vWbRwbyf3n7cIQkEOPdb4/HZIuEODcrJk1v
+ 3n09iHPk2IfjW3CWmwd3M3ZwVZMWgfKGmmeAl4NS1Dt161vtaQuMog9V0DjHwFXz+JZHBcnF
+ 8TBd7rtn+gUL+IqqUG/eyaMDI3wXeF1llPOEqtlqnlGQ0MCKwhbjQpi4q3RwvrzGC5sUujG4
+ JpkFIh98fX5WnR+Pg2oSwPvi6AezhL0/I3z3IAaVRnUhINVGpYkvUWmlJJLo4lnNfSC5yZ7+
+ SXWSDpkkPBVHuo276IYDMlMxpRbgqwKP3PFwoO8YUVtwUCqFu6wdcBGETIb3w2NJs6HK8rUr
+ oijf7h6xXQb1NOY3L4S6SocmDaVtdd5ELa5rotV8ouK6ZuIVFDZnylPM+8uVNZhCJqlTz9hB
+ 72fgc3W1yxaWaU09I2r9F21o3gVG3+z+7M/bejXfFScsolDoCT7AllPimyay2vNObncBVyEv
+ 91N9TXpXBfF8qEMckrtJBDOMvec8ianKpVl/yHQNMZDQ3KMCDAegCp0XSQjRTbR8XykUqUUs
+ Ym8w1YlVGtukN3tWGnqZzi58X5EFBgIbQ5u3tkx3hGRjBBPJ870+XOvDN2CKafQBh753Hy4L
+ loq3lbdaFoPkKMERwhif9lcmRYlzaeEOzwCe57PMMlYcgZsckFOYvioZnSIcBGVM3WtGj1tK
+ +xYWacKoLV7VMvdiMH4ZYwdpFsLHYc5zLgyw2F/FiY1B37moEI3IFf95VgTckaHWptBJFajF
+ w5rXaR88xg4GjoL+vOu8uZTxNgfLPiMklVqfZWpXEFdopTlN5bAoWllps+lKkZocVXUJMR2J
+ McAAjPAGhavo2Yo5tF1evgJzfRsEg1jyDsBlKzPkxeUMrtKl5jDGoZ9SFpXflidKJRmPtnsW
+ TMvIgLHmZVUKZWxFxqsYSlKrzatGGyxwUo0CRi/SAjef7vmf7eS1sXs2vDKAV5GJy5roFFUG
+ YPW+y5xIbrKBNonLhlT3W4wJp1fk7RxCcq8z1FU5Gpg2cZ9r/TaoJA4zFMYvZBPCIFD7TXhz
+ i1NL2Qv9L/MsfrWH85u9Y8i80qYQvimY6j1c3yoC7WIwDK8vKi1nooJHvwi8jHQnuanAVZk7
+ DwHE2OXduPYB5ET9osS4C9DlaIoOFCavhqxQeLGoZr4QV66/6vxC9S3dWKpQfcY4lfS6V4wP
+ LGDGjb2DkMWyckryOhGvVHiwJyFLlet7k0DwxEDFyiJcklLlp3HmKGWrKiosFJQtS/1le3yv
+ WmglkaMoQD5aJYdqdOU11UF5Jq+tUM07Ej5VpjukSRUZuFeJZ0khSxAkhNRSuadoQamovLfc
+ uKRSIQzIcJ5z4WgegRMxRRlShM376nlqr8laKweWaezCRanHsVRkzseXfQS7Mbtn3FW/yDqW
+ DIMD5UhSw36byBZnq6IzaUVEhG+ul5qv6KU4Xhnj8lWrgZw5NQp5UqCAUOEBsDdvvxmdQ7h3
+ KvWswkPFx29C9/MvAkG6ch3XUq4yet5FODlvTKDyXTmoe6NCceYW6jIHpLkOKSnehrMhFLIr
+ QEco0QTSXBSBBHof1+NW6qVoRjaPROYul7PHJFVKIo66YuNwDm54kI2sFEkJLMZd14892wZQ
+ 2bXsJJj0jwEQzjNIx1hJonFSd5XqIloxtJXOcAtgdKqQQJlnlYQKCtwHmGp1BHGuwgMREVSB
+ QbW4Ds9xlu8RwveVhiJa7/mmpRdUQ/EmIp7v34R1mctpYHFllThlAAu98Iiqma7itARfAUnM
+ ZkwKKkhL+XtjQDCEMW5jwKAOBHR/MPAm3a3f5i15aMEZc2A2Ul46goOT05D6LWqyIpKOuAVh
+ AAFgnbeopgU5nlN3iEm8K98hHaTH8yTm873/GAQxGGrMgN03IFUkJKyZOyQhUC5unlIeYp5j
+ dioDzFgWSvcNBHiXAa3UtbKmIskFbkkMdYsADhKMQTGa8RkXHOz65M8Dfs+reiHxCApGhC9t
+ DfYchBZrFT9kd8pgYkKEMiVpFYUD0RBzhUsgLO6HWEimbgBH3ypawzUIUXlni3KogKTO4AzA
+ e4iEaIiA4J5V5V7drr6r4WIPnBdRwE0GTV3Rud4xiMqW3v/wv7eVl+YYGV5zhdRVKsw31GXz
+ FoRmo8YsfYYffCQb4505+/n4jaFIDtUFVnB7r5VhnpU+Zq/KlJpoFmbBIMu4GearxLZEmecm
+ oDlFY+Yf9yKKuic1uDgCITJyuAOwDCGEuwdAyK1O17sI5t6hwx+O5QU4z2Egvsd9VIbDPdIT
+ B1cLBvnVqhUeoZJajFqoHXdVqV9Kt/LdjK92Kt1NSpYrGzwzHozUYqJ1tcuLQSxMlIQgGOZD
+ EOMAO81QxnLptusHnBWyfPzJH8a4mmiWws74OzAOorBRYBteGaRCnI5xBa7HMQBzD3K9o7LQ
+ ewhAonAbwrgPWN8AtgJqjgWiejcPD0ER1rsHDr6/rX3Onc29NAgGtEwpwHFiqqx6gdbMVMzn
+ HGdCGCnM62tNCw5nA4ouGAuGxJgkBNMYP8bMbmJcOBhFevN918Y+GGxTfF9srTTEsmYtKY8B
+ wYOQyxXXRVswlWcr4sjroI4gLpUGqa4BiziAAFCAAzRisBUkjRvsHUTBURwEnFYxNSYgobnL
+ +srlheBqA6gbUrFccYbz0uF5bKV8izhU6tRKguZkBm/AELgusLs53OvBuRsXmSSAyXjhAsyY
+ zj3MBhfOU9OIhskQvsxvSzuqT0MQsGAW4ygq7b3GY+wttuo9v6uWCkAwaYFw5Z756xDtGSBw
+ P1HPr0e8VlIhBOBzjz3n4fglMQ3a+5ChD0e6tgK8uLm4XVlGiK6osAEu5w6VKxUQrWagYouW
+ gFQa1RI+RCAVYCYR4GVXjdH43DNmlZSpa2N0H744HMX1CvuzES2X12eGHxOBuYBlcbXSCUk2
+ yV9BJsQ78rIy1s67B8k4HiflXuIkog1YXMQGRdCWUyMG4rZcwQos7/h29LlJMTTzrkqlOrLm
+ MpXOFuku1FMcrRhfxSWFTNLZuLpoA0Tk2RmHMZIasJL8JtuuMSqbaWGSd1N9DuqsYsbmIPVf
+ HLF9AYqo96xCfNdFlQtdYbxVi2lwcrbBRBOXkIJff3s2uAp388IglipDHMClztoJokp27dWm
+ QeLIPJvmCWN2PRMiiWFDMogAx3kkiMdS5SY1AMEVuBtMxrysanVfLVmvisWzgoXlbzCUcWK+
+ xty6liIhGM4vxspuwpHzwivVu+mrFd2lKkonYJ7SC5jLt8ZSsLVxGOOqnR10DMGQz8bgetxC
+ Uog24ADuHECeQ67vHNrAUVSeoza9a/DNoqm1llaPSMA8IMivBgvCEQDSWkC0TEu3gizOqvCh
+ +J6BZ1ArN0Jw19ot+FoexjiyJ83TwEhdkRzXDtLTO+Y+bKdvEbtS4RKK5YMqpCxaXX0AKWNX
+ wEFaqlKiDknyWB8D2a0JLC5GIiDNPQhEIICkwqgmhCJpLaUGOGlBDIZRG9pujxWE8T6iO9c+
+ VQCgJmNV4xTZxknFx4rWlnpt+bdQR/cKjWRrmtuU9tZ2FZ3NOXiGYCfxfmkEDJQKtsiVc9Nq
+ 4zZMgCeMWdKwiHgFF8tClsYY4ZZLVcqk5rh0PWJlkNmMvQBkUkJiIJJoI1AA8qwA73tc5Dni
+ GUg2Rlva9bx+vKP9iIUYLQ+kClo7yVC2qU7rWXCfCSTO9w5urWg8T6wlGFXlI1JVLZ61iZB+
+ x6rkmVEwW1X5EI4Zk+iWUjQ9oFWce0bblFiDcPBRwWVyXVe/ZnzVQsQg2ZkiA4gVQ61wCMDa
+ dAZi29kB4nTe/CRC8VicA7DgHmlq5ZTBttuDb1MVRaPdw5XOly5wyIWwZQF4tQTFy/L1WxpS
+ XVlpgzKc2RQDrgqzEE85d8h25LSwicZnCkE6MCFNYCwkiLvv3dRcsbllqe4ynbDMbLqfl4gQ
+ NIAxVTpV3mtMMBn3lqYxarg6dQZQnlU7PADQPe81Actt9NxgtOfcdwxkNkmb2uZ2mpD6BtEN
+ KqBw93K3imbthfQrtsjTKvFU4XfrYSJGM+1SBBBVDVrr/5urGCMGay1lO124P1TWfJ49dY5B
+ B842dc9CSHldrXBYepyV7FZ11K5PlQdngypkGTN/1A9ZEA+hOAchWgmFuxGrqAA1hut10pqW
+ uDqqQw5OMQ/Bve3lUuq4yV7zChxUBJY3UyWo99rnpdQudQYR4AQziSXBxkDSczKaHEIiJBsv
+ ArTLEcJ4RgOQbM4Pddvs3kFajBWxfOudVF/LyKk89xEVLostahfu4BhMMT4m1kbM2PITzDiM
+ vxA/RGssO1KU2YdFlzWG+3FKCz5JTquiKtouVV3lCf2Lg1pU2hpOnFHOu+wl++Ge78p9U02t
+ cNNHXlslpgwzAw5BkJiqAXsq0zVJiLHaBAHCqHLvOvdbILZ4mDFS8cNR2aRHpEL05zoHQfsI
+ 2oSdDQaLe3CaJLoP58UM22etAnjjGkHMfPURUJw7wn0GYlAIVeyM3UHxQjAClzrM4yEx3D2c
+ naRUi1bAMO+rUtDKntrRqZUGeTW9X5mTe6m1gpbZtrKQyzQGDsdE1Gszea4899215yTKWMo5
+ CWCm2rRb4DLHwDPn2iERvoEf98vh+HYsFV+YBu+GV8/BCIYmpiXRKgYZ7rKPil+RiDarIW51
+ BEAcgJMQDAeNmf2mBqsocbmRanuLnlZJEmeYNLaXWJ6KttqZiQS13IMUeaeFTevNd56v19PM
+ nJvXCEHF5cBrLJgJl0MSrYDDMZuxmdEvQ1EhOMkqEgAfqXNSpR1EIx2IXvQ8wpTxxRSu2zsG
+ 04MH8UtlV1edZmm6sCrHXYg/I59v7/4y/+8ckGzP2AtyU37UKuEKu0sctRqs1HA5Bwfvq7oy
+ 122x1SKmKiQjsvMmknlnYAUb5LVdSHMQzFPopOArBJaJhDQIYg98W66pKIXnRd8xZOnx6hr0
+ 1bukAfIjbPtj+iat5NukFFxDejaLgqnolnOMeQz9DLiSXRnIElp0pM5Q32CJPOdAiAaBCj62
+ qKhcSOvvqbgW6bQMzrsV8CUp6ddWhbVusrRwC2hbENQeliE4FVwCrvR1Qcj2FaM+cgaoNIf3
+ GOnqEIzV2LRHIkiIbytEyZjrt33HIBlRi8QnddorxIMBEKQdM7xrvEUvWmY41mCipk4BqoM8
+ FQAUsm+3h/I2DufuVeFe6Wnxn4KEVE8BxGq4chnTq6WAK/TOeWh5YDVdVdLw+7XpPsRRIcYA
+ zgomWsINAdRKISbcivGEVfLCeF0FJhly43ZIjTPUxQS1kRfnW4REEIQuylFaPXxiCJLkNzh9
+ hxGGpM3MZUxUdtGAESsbOZHNHKMPU1eJaZuleUfHOQs4qSpHhMltbvl021PFFSZaxZJwB4lo
+ EubwXfuUUYE8tzblyS1vKV6+P66sqqVKHbawBB/CuK78qsxsM/dKsop8sAHLLXpDcIHXbAv7
+ pM/mdhGreFs7/aVai4ZwovTLefDMuKsxo84Kwo58TN4GoHFGgbt2PtWYwVFh3jUonsxwL2ek
+ te4DwlF/GeYu3FAGrzhRDkETwiofW2uZlLR6TTt5Y6VnxzLCTTIPjGCGLMg2LsRpt1ZSA7EY
+ 0Xmzes9xL6SlxooAlOxrDoJwCMN4N3HWH0ZNs7iHKO2wlA1LtWkrczE00WZaUDSj81Uh+wx7
+ olpOu2CljjTql+9f/RWkaZwhR/3synJ11bJQuw2l2x+spXSkrixjqYCWUPznEozKlnyXuvKr
+ aKKdjTARz8u4wJnqobY4A+7jXCorA59NyPkpDWLM3i2gyy5rZyTKNlEN53BZMQpC6t85PJZA
+ 5DS5X8VQtdftrpinumrn02bzeTAGSywNKu5JtIsUj1TrYnWuw3k1yJXWlpWskK81McviiAr2
+ eGYt10PgylzbQaIIrfeb+YMboiCVJECAcRhDEfIiFrg41ed93F4RBuSVl3EUimlbq1SasXeu
+ n1Il+q5uQt8movohsRjBvaLxNNCos1hkN5croleV5iztR+WhOiAdAMYBbfQM+MQeMXAvg2Vu
+ Eve3rcmy3qvCN+8XjW0OkzrTTtt04aZiTS27RvjlntCQhgsRA1zp9VznotzNzUohG6cxOcq1
+ IEbjShKbnxQngxdqTJ/tQZaNzpP1W4C3suGqkDCHPkiqZ20B1r4KxdNWeVwhHMXbWbvIsk5J
+ Fi+FDfJOKgDSSESeFsq3n1nloG3X2FylUthWmvWtcxyDgxDLuy3UrSypSsrSBAbXbq0Q9tme
+ vw3EsIHghAzMV0mW+wjDeHNecLM2jL8abgxq/KTMt6XflyW0cAZfnI32Va6qJm2C0HCXJIOv
+ +ogIjdlawl56fSwnp7ZwhYbKZy8NlOsmX+ldgDTpSpW19wwELtf9I1ohl/LwrfKC3DyvqjGr
+ AaueGcEAmuvdBgxtu2WQ7REGESGtjCwYqS9EcY2hqJFsirEWP8sBaq9+424iDUdtEa+NagWa
+ NDb7zxFo1z+S4zyJ1Ka+ttv7bv47oOXrmI8tXWU/ymLmGrtGYWKde8yb8cxgATmq+DfbMxbM
+ hCwqbRl+yf1tf5jmOUlAHllBy1Z+le2rzjh71M5L498sNmqiIkIIN0fZ/elftpWfSRXYlzXU
+ FVxArAMujDsJooowZoRb1uDpD4FLO7suyu27zACCIGR/tuC9iD4YflMgWOC2FXErSM91RFGi
+ S282mDZqBlx6FZfxLAyycAwfXGih1G6ViYjQ9vDtqVygs8Wxhb4LWLaHprRxmco23mlDVe9D
+ ZEFCkgJR4AMnpoIgE9D+RmRpgHmb/eEB97dCRd9WV1egMy9VH21YXVrd4f2MemYBDp0XX9R2
+ FaypR++07J3dxNAt619VBdhqqahHhbTitp2XKilqK8YWqlYoEaILq7RNYQUIJKP5TXVglotf
+ uXZobL7wyad/3P7LBvsy1jbOYaACrZDRgBypj5JVy40jKh+qCAOTtGC31W3Dc9wUMZZOLqCZ
+ 9IkElEaH/KLEpA2CI8hSNYKzsNBy5u+bIgxNfCu/JV3DGZjHo/9VyK7SI4AbXDZEUHHpui43
+ 02kLwbZhzJa0m9FyE5z+D8a362Xlp8f6/bv3T42dL4pCb6vyLQ7aqKuKJNa2cP82b9KfCLUn
+ THt16qOlf01sI952S/xN5UuByQKd7Y8MqRDowPEkaxkPK3dV8o1EcSx8W1ShiHxho6LUhbZS
+ a65LCYxNfogPTq7ADuJbNAuZ4ldtcVW2sZl74eqhWjZ/NdJqY9/j0DbTWW7f3h/58MTshoFA
+ r375akgTBBb+NhActkw/ANwf4ZAkE0nqoP+DKQPYxg8IQCW2s1HbhLRsm0ou40kCIIgtzYhT
+ idShezlBpHb5TsRdTiZ5fBU1BnPwt4KgrX4r+cozpk5X5Tfa079KR2qs5dA8B1lECG+HiOq3
+ KjLwbttNlRJu/5UWGRVKWS5BuHz14LTvwN/ntu109/mWaKlOwFIxkFcaYs1pv3NZi5eaJ2GA
+ igXB2xL4loAbmzGNKPbGa0sFVR3j131IgvAykMW+qB7PW0GHeUhLeyuXs9JucTTPTTpTmZ61
+ PzM4TE8Kf61IQpO1ljkXj1ouL09KKpRotXEeVVs8dVTC2oKjVjrnvbleb+uxf2z0Y0Of9fa2
+ a7XYOpZC8AaLC1Mdz1/c2VaqtB9OW72PUM3MbBisDGGqrEKNCiRSNy1pbMlJhRlDVc42AOez
+ GxwC0oXDEa2lj6QHAVqFlnpsfpXnt5b2M9saafcqSc6ZGH+6UCSYt1Rxdpu9Fe9K7zcHiTip
+ C+f9HRW12Ba/hVfaM7mVwi05X/+T0rGxac/Pr3eGE9BfULWJA8QbRN5OZUY//vTw95VqG08w
+ SU7ywQee5TUGQvjWRCJKQcwWbTVzh3ieGMZw3T7+VfojomekBYy8O8TkUFSAD+mFsBBFOwji
+ /by/8mCYr7TEqtAJVdP+xVVEts+M30L4Le1ux9dCCEsVYQ1+WzhCFJXSNsEtm674DTFs2MPG
+ rPcgO7jdPGdUxGz0bnOpCOWf8DKa1Ze1Urk5UNun5J63DrKN7sY/EG6K3KmXYmjNOZIkiPc8
+ m9OEEizsT4mzvMeylr51ZEswUUsp3W8xcY5DcyVtrXJrKwKgh4tftUyOYWc0Kzdqk5727sfh
+ jvYBW2507dy31Vy1HRSboF0qzPZX9iNz3sZsLbnAodzHwuotm7h2/fcUcZuntltr0YP2HGhd
+ Z0V+qd5Rmb8plCiI2X+FQVJrZlJniLMsECw1whkgJaLOGfmxPfzGdjXXKeGW9CNyRR+VNuUM
+ rEhB23rkXrZMobUm7TBUuCCbk9tr8C2dbuMD7zQPalVu22w1l1iHW+6PjeO4zK/fPNiujSSp
+ Iyu6+euPjHPhkctXjm7XdVYJSV213WLeGQajtpIe99onxoSugCXV0wKu5T79VZ2WRCyO2NKU
+ lgR2RIQm6FXrFDsrYq1dNpPEtqs5wvuOp7nqXy+WG4Eud05d/rFBf7Cz3NsLQhT08djahbyd
+ M9pZKUcgSdRHKtQEkzfGK+MEFClA7BFV3swvqhTFnWsjenWb6GrJA+lta8X+GKhN5lyDuVhe
+ u9HygPrXpNIcVFm12PVd4LEJbnMZ33jWIqcyns30ScPyr7AKaeVYUG+lKIrtaXfV5mXVcbUV
+ bg5B4l+gsj94o5qqqo8D24u/HH7bWLE5ZSO50dWIkazmMH5JznJpuHMz7yruxcAcAPenngUR
+ 2yEJvFz0lgDqt9XLZVjzIqvmSQohvRl6gdqWlI/Q08ZrqlSqfA6ENgHG7dRU1TUV02dvqvKs
+ LjxPrTQ+qalmYNWm0FSQc9zd3l+Q099cOcrpk4pWUbXUroljy7tVWDbPKUqQO95Sg/UW9Z/N
+ avPOsC929WvRaH/aA2gc19YhBrIOg9zcIql8TfudYQywV+SwLQ7c2M2KOsaEeW6jxFh/mpA9
+ w/FJDgK1WLiqTN+EyAiR1PiuySVitVCrpZIRkxdYyVOF7FIXq3amoIPbM7ly1vYQK9pbXVfG
+ tGhoxdNVSraBW4tE2y4X0qo3a08Y2yvaTtFE01aK1OLyf51L/xp0+n2dL18vQRzhmU2hR2W0
+ xe0K6/T/Au0c2xRAQLS2K5dtMll5EdXCsBcv0/9yxQJpy42OEKVPiiRnO5IY0lN6ocIQxM79
+ d38VR7elR3s5GmwlSQboHBe290nS0jIKbXCVqZE8sXYCb1/JkkDZobVxtkv5pa1X1oRUG+Yg
+ DGThj6V6uXFzvTkRQ1l51PJ/B4oBtu9yf8rWWFr11UKq1GKlW80zMswt6irk0mSxIsnsX65x
+ C5uqmy7Hn9vfxkfL8t6WHI55TFsKQhKxJ96tGl7+S8Uy89ifvbWdVos82+EoV7pVvP3/ZVuu
+ t8GCw86xzWWctyKg2T+OIv5Fa0OKWBk1N1K1m0RTaxmNhR1sR4r+4rG43nID6/a2qRaNWqko
+ pY1/imNV5NdeB21uBNmlmJd/VtpEtUlkgdHSE74ndam31Cf1tirwhyhtmd7/o4yto35e75M5
+ KLuZYTdZKyffyqhpsxMTqcARLcGDiP4jM7VXgmxtw9abhvZPExFmuNWzOkAMiCHmGctmymuV
+ e3psDwxmbZYthSSOQ6qihbstLR8bA83SUkZTuyGNXTAvKdzSqjPRgFLrrSyrwmgk2Gb8VBze
+ XqBlJyMM1eg78HFmqiCl6sqMrgzKxtLr/Y7Pr5ehbZJhAPr51aMB7Mtv10mndoz9bZ4DVNXR
+ bkzrouwLm2XmB8Z9wOi8DeXYE32REvatVb84x95mEDn+pXuzPpE0cHlbQFu983oeZF7EHol4
+ r/8Qp2Scds5fODi8t4uXuKCHxn/nOwqEps//syx4WfsADxBZwV5bmFQXVmlvtlZ4yZbF/jUJ
+ fOZnIhqcnGGbN8UZJB58Ozw4Ns5GF3Obru/P8KwM7N7OyWF8GeJKRg3k7btnM3FuDCTv+uQv
+ oxij5RUMtc2q0/3yI8eO754N6J65jb3b/6VvodDvC2APD7Vlj2UBTAMnxu0BRkLZleXG28vt
+ GcEpb2Oncgi4fvPw9PCxrRYvjHFUZvrosWXgJpAPZ/WgIF4VpfIkpao7wwNqblGhRLN/59QX
+ uNpsIttQerl9d9qZo1psBMEkd+7ZY1Na3Xzs2LgPbu0a37Pntwduf1ULpzSZhjFHm/u4MDsG
+ q9dv5OsvD2QJKLarhbD642+uDyMrLhWH9d8tQvVPn1/dclX/zVVtloEX5Bt/F7X5d6K3vz4a
+ O5GTUoFLnN0qZl5RRdXmI+0vs/xvl9barNc+qjt7fzp7YdcgyuMnF7f2DUdijCtXjw0mMZ4v
+ Lx+Zme6jbU0XSSbpubfmSmNHpc1+BWCHfOctayxx5xlmyp1vJ0E49A99l6/uHwQBF6aRCESc
+ lkZiZPCQktPzuB0k5/q1L6ZDB9+bVvsP/m2WlF1DtYzw+SbsbEB3761FjnrCMbi5bdjpdAhr
+ 6VsBPwimJ5sd08X97zGVBECzfSLOExsRgc1S7lEStdldon+9aLVvReUVB64rFo/NCJkdgftH
+ BxL8R0Bbf2Aq8K/d6itDgqi15aqG8jlt7VV1TPGsZQ1Y+f5lRSrNUl1y8TpaZL2bup2j9sxw
+ k/RTA18IM/YeGJlK/0I+ExKheWjSGSatM2FuXD/iL31PDe5lbKtsBCRq0s247cjRXVuj2DbA
+ 663f1wXSVBfA+fpVj1SKU2o3NQZANoYudt7/T0aEdeT4xtbLKRRTzgKDZBPWm+tcm67fsvbz
+ 4Ghvu57mEbVzZtgUREKgsp5tvdhqgjK1xQy7bidy1+120VodbYx/JtxUphrDOgpibzQphjvj
+ oI2oNmM2Heh/cspwsik/zlrm1c87sxqbx/rkyvTu7ZzBpOvXRmrzbxibUAEdaHD04KvXj7e5
+ hXUM7NI4xrZUY73M86GXdUZttWVVq8NEj588W3tPVKY/SyhwySaIFLRGpiXbVZjg0o93/WlM
+ yBCKWqGCMIGQy4lTSnE/GGqNBLbj3toGfDYk3ziosrEoaUZuG3f37+nVB/CmOBYh3TstC6lu
+ oI1QW85ePR7GXG+tf2jAwbacPb97SAs7iJExTvutweUo4p+llQq7f2+2o/fnnM3DOYH28uZ6
+ gpmLaR4AIesarQvDI5OQYiwhyWKl9W4Te4eLy3iv1yM+GMAR79a7r8uU9g9AvV/RhYAlQlWH
+ bNDNxh2tCG7eUuAw+8U7pJKogjEHGQM+vnUqivctt4iEhHIm6/9T2z2cF/Dwlhw8Okwao3Iy
+ wG+cVK9z4/DMOZU1ahM2RYBjddpYp7+O+e08OD2kmA1EpJu3jwxC6Xv97x/r9Dpi3Ll9YhyI
+ c9v+NzNj/R/B5L9fXci2wQAAAABJRU5ErkJggg==' base64Decoded asByteArray readStream!
Item was added:
+ ----- Method: MorphicProject class>>defaultFill (in category 'utilities') -----
+ defaultFill
+ "Answer the default fill to use for new Morphic Worlds"
+ ^DefaultFill ifNil:[Color white].
+ !
Item was added:
+ ----- Method: MorphicProject class>>defaultFill: (in category 'utilities') -----
+ defaultFill: aFill
+ "Answer the default fill to use for new Morphic Worlds"
+ DefaultFill := aFill.!
Item was added:
+ ----- Method: MorphicProject class>>initialize (in category 'class initialization') -----
+ initialize "MorphicProject initialize"
+ "Initialize the default Morphic Project background"
+ self defaultFill: (InfiniteForm with: self defaultBackgroundForm).
+ CurrentProject ifNil:
+ ["This is the Top Project."
+ CurrentProject := super new initialProject.
+ CurrentProject spawnNewProcessAndTerminateOld: true].
+ self convertOldProjects.
+ Project current isMorphic ifTrue:[
+ "Set the default background in the current world"
+ Project current world color: self defaultFill.
+ ].
+ !
Item was added:
+ ----- Method: MorphicProject class>>openViewAndEnter: (in category 'instance creation') -----
+ openViewAndEnter: morphOrList
+ "morphOrList has been reconstituted from a file. Open it in an appropriate
+ Morphic world."
+
+ | contents |
+ contents := morphOrList.
+ (morphOrList isKindOf: SqueakPage) ifTrue: [
+ contents := morphOrList contentsMorph
+ ].
+ (contents isKindOf: PasteUpMorph) ifFalse:
+ [^ self inform: 'This is not a PasteUpMorph or
+ exported Project.' translated].
+ (self openViewOn: contents) enter
+ !
Item was added:
+ ----- Method: MorphicProject class>>openViewOn: (in category 'instance creation') -----
+ openViewOn: aPasteUpOrNil
+ "Create a new Morphic Project and open a view for the project"
+ | newProject |
+ newProject := self new.
+ aPasteUpOrNil ifNotNil: [newProject installPasteUpAsWorld: aPasteUpOrNil].
+ ProjectViewMorph openOn: newProject.
+ ^newProject
+ !
Item was added:
+ ----- Method: MorphicProject>>addDeferredUIMessage: (in category 'scheduling') -----
+ addDeferredUIMessage: valuableObject
+ "Arrange for valuableObject to be evaluated at a time when the user interface
+ is in a coherent state."
+
+ WorldState addDeferredUIMessage: valuableObject!
Item was added:
+ ----- Method: MorphicProject>>addItem:toMenu:selection:color:thumbnail: (in category 'utilities') -----
+ addItem: item toMenu: menu selection: action color: aColor thumbnail: aForm
+ "Add menu item representing the sender to a menu"
+
+ menu
+ add: item
+ selector: #jumpToSelection:
+ argument: action.
+ menu lastItem color: aColor.
+ aForm isNil
+ ifFalse: [menu lastItem
+ icon: (aForm
+ scaledIntoFormOfSize: (Preferences tinyDisplay
+ ifTrue: [16]
+ ifFalse: [28]))]!
Item was added:
+ ----- Method: MorphicProject>>addItem:toMenu:selection:requestor: (in category 'utilities') -----
+ addItem: item toMenu: menu selection: action requestor: requestingProject
+ "Add a menu item representing this project to a menu being created by requestingProject"
+
+ | color |
+ "Color to be used for this menu item"
+ color := self world isInMemory
+ ifTrue: [Color black]
+ ifFalse: [Color brown].
+ "Menu item of type appropriate for current project"
+ requestingProject
+ addItem: item
+ toMenu: menu
+ selection: action
+ color: color
+ thumbnail: thumbnail!
Item was added:
+ ----- Method: MorphicProject>>armsLengthCommand:withDescription: (in category 'file in/out') -----
+ armsLengthCommand: aCommand withDescription: aString
+ | tempProject foolingForm tempCanvas bbox crossHatchColor stride |
+ "Set things up so that this aCommand is sent to self as a message
+ after jumping to the parentProject. For things that can't be executed
+ while in this project, such as saveAs, loadFromServer, storeOnServer. See
+ ProjectViewMorph step."
+
+ world borderWidth: 0. "get rid of the silly default border"
+ tempProject := MorphicProject new.
+ foolingForm := world imageForm. "make them think they never left"
+ tempCanvas := foolingForm getCanvas.
+ bbox := foolingForm boundingBox.
+ crossHatchColor := Color yellow alpha: 0.3.
+ stride := 20.
+ 10 to: bbox width by: stride do: [ :x |
+ tempCanvas fillRectangle: (x at 0 extent: 1 at bbox height) fillStyle: crossHatchColor.
+ ].
+ 10 to: bbox height by: stride do: [ :y |
+ tempCanvas fillRectangle: (0 at y extent: bbox width at 1) fillStyle: crossHatchColor.
+ ].
+
+ tempProject world color: (InfiniteForm with: foolingForm).
+ tempProject projectParameters
+ at: #armsLengthCmd
+ put: (
+ DoCommandOnceMorph new
+ addText: aString;
+ actionBlock: [
+ self doArmsLengthCommand: aCommand.
+ ]
+ ).
+ tempProject projectParameters
+ at: #deleteWhenEnteringNewProject
+ put: true.
+ tempProject enter
+ !
Item was added:
+ ----- Method: MorphicProject>>assureFlapIntegrity (in category 'flaps support') -----
+ assureFlapIntegrity
+ "Make certain that the items on the disabled-global-flap list are actually global flaps, and if not, get rid of them. Also, old (and damaging) parameters that held references to actual disabled flaps are cleansed"
+
+ | disabledFlapIDs currentGlobalIDs oldList |
+ disabledFlapIDs := self parameterAt: #disabledGlobalFlapIDs ifAbsent: [Set new].
+ currentGlobalIDs := Flaps globalFlapTabsIfAny collect: [:f | f flapID].
+ oldList := Project current projectParameterAt: #disabledGlobalFlaps ifAbsent: [nil].
+ oldList ifNotNil:
+ [disabledFlapIDs := oldList collect: [:aFlap | aFlap flapID].
+ disabledFlapIDs addAll: {'Scripting' translated. 'Stack Tools' translated. 'Painting' translated}].
+ disabledFlapIDs := disabledFlapIDs select: [:anID | currentGlobalIDs includes: anID].
+ self projectParameterAt: #disabledGlobalFlapIDs put: disabledFlapIDs asSet.
+ self assureNavigatorPresenceMatchesPreference.
+
+ projectParameters ifNotNil:
+ [projectParameters removeKey: #disabledGlobalFlaps ifAbsent: []]!
Item was added:
+ ----- Method: MorphicProject>>assureMainDockingBarPresenceMatchesPreference (in category 'docking bars support') -----
+ assureMainDockingBarPresenceMatchesPreference
+ "Synchronize the state of the receiver's dockings with the
+ preference"
+ (self showWorldMainDockingBar)
+ ifTrue: [self createOrUpdateMainDockingBar]
+ ifFalse: [self removeMainDockingBar]!
Item was added:
+ ----- Method: MorphicProject>>assureNavigatorPresenceMatchesPreference (in category 'menu messages') -----
+ assureNavigatorPresenceMatchesPreference
+ "Make sure that the current project conforms to the presence/absence of the navigator"
+
+ | navigator navType wantIt |
+ wantIt := Preferences classicNavigatorEnabled and: [Preferences showProjectNavigator].
+ navType := ProjectNavigationMorph preferredNavigator.
+ navigator := world findA: navType.
+ wantIt
+ ifFalse:
+ [navigator ifNotNil: [navigator delete]]
+ ifTrue:
+ [navigator isNil ifTrue:
+ [(navigator := navType new)
+ bottomLeft: world bottomLeft;
+ openInWorld: world]]!
Item was added:
+ ----- Method: MorphicProject>>bitEdit: (in category 'editors') -----
+ bitEdit: aForm
+ "Create and schedule a view located in an area designated by the user
+ that contains a view of the receiver magnified by 8 at 8 that can be
+ modified using the Bit Editor. It also contains a view of the original
+ form."
+
+ aForm currentHand attachMorph: (FatBitsPaint new editForm: aForm;
+ magnification: 8;
+ brushColor: Color black;
+ penSize: 1;
+ yourself)
+ !
Item was added:
+ ----- Method: MorphicProject>>bitEdit:at:scale: (in category 'editors') -----
+ bitEdit: aForm at: magnifiedFormLocation scale: scaleFactor
+ "Create and schedule a view whose top left corner is magnifiedLocation
+ and that contains a view of aForm magnified by scaleFactor that can be
+ modified using the Bit Editor. It also contains a view of the original form."
+
+ self inform: 'A Morphic editor has not been implemented. Enter an MVC project to edit this form.'!
Item was added:
+ ----- Method: MorphicProject>>chooseNaturalLanguage (in category 'language') -----
+ chooseNaturalLanguage
+ "Put up a menu allowing the user to choose the natural language for the project"
+
+ | aMenu availableLanguages |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu addTitle: 'choose language' translated.
+ aMenu lastItem setBalloonText: 'This controls the human language in which tiles should be viewed. It is potentially extensible to be a true localization mechanism, but initially it only works in the classic tile scripting system. Each project has its own private language choice' translated.
+ Preferences noviceMode
+ ifFalse:[aMenu addStayUpItem].
+
+ availableLanguages := InternalTranslator availableLanguageLocaleIDs
+ asSortedCollection:[:x :y | x displayName < y displayName].
+
+ availableLanguages do:
+ [:localeID |
+ aMenu addUpdating: #stringForLanguageNameIs: target: Locale selector: #switchAndInstallFontToID: argumentList: {localeID}].
+ aMenu popUpInWorld
+
+ "Project current chooseNaturalLanguage"!
Item was added:
+ ----- Method: MorphicProject>>cleanseDisabledGlobalFlapIDsList (in category 'flaps support') -----
+ cleanseDisabledGlobalFlapIDsList
+ "Make certain that the items on the disabled-global-flap list are actually global flaps, and if not, get rid of them"
+
+ | disabledFlapIDs currentGlobalIDs oldList |
+ disabledFlapIDs := self parameterAt: #disabledGlobalFlapIDs ifAbsent: [Set new].
+ currentGlobalIDs := Flaps globalFlapTabsIfAny collect: [:f | f flapID].
+ oldList := Project current projectParameterAt: #disabledGlobalFlaps ifAbsent: [nil].
+ oldList ifNotNil:
+ [disabledFlapIDs := oldList select: [:aFlap | aFlap flapID]].
+ disabledFlapIDs := disabledFlapIDs select: [:anID | currentGlobalIDs includes: anID].
+ self projectParameterAt: #disabledGlobalFlapIDs put: disabledFlapIDs.
+
+ self removeParameter: #disabledGlobalFlaps.
+ !
Item was added:
+ ----- Method: MorphicProject>>createOrUpdateMainDockingBar (in category 'docking bars support') -----
+ createOrUpdateMainDockingBar
+ "Private - create a new main docking bar or update the current one"
+ | w mainDockingBars |
+ w := self world.
+ mainDockingBars := w mainDockingBars.
+ mainDockingBars isEmpty
+ ifTrue: ["no docking bar, just create a new one"
+ self dockingBar createDockingBar openInWorld: w.
+ ^ self].
+ "update if needed"
+ mainDockingBars
+ do: [:each | self dockingBar updateIfNeeded: each]!
Item was added:
+ ----- Method: MorphicProject>>createViewIfAppropriate (in category 'utilities') -----
+ createViewIfAppropriate
+ "Create a project view for the receiver and place it appropriately on the screen."
+
+ | aMorph requiredWidth existing proposedV proposedH despair |
+ ProjectViewOpenNotification signal ifTrue:
+ [Preferences projectViewsInWindows
+ ifTrue:
+ [(ProjectViewMorph newProjectViewInAWindowFor: self) openInWorld]
+ ifFalse:
+ [aMorph := ProjectViewMorph on: self.
+ requiredWidth := aMorph width + 10.
+ existing := ActiveWorld submorphs
+ select: [:m | m isKindOf: ProjectViewMorph]
+ thenCollect: [:m | m fullBoundsInWorld].
+ proposedV := 85.
+ proposedH := 10.
+ despair := false.
+ [despair not and: [((proposedH @ proposedV) extent: requiredWidth) intersectsAny: existing]] whileTrue:
+ [proposedH := proposedH + requiredWidth.
+ proposedH + requiredWidth > ActiveWorld right ifTrue:
+ [proposedH := 10.
+ proposedV := proposedV + 90.
+ proposedV > (ActiveWorld bottom - 90)
+ ifTrue:
+ [proposedH := ActiveWorld center x - 45.
+ proposedV := ActiveWorld center y - 30.
+ despair := true]]].
+ aMorph position: (proposedH @ proposedV).
+ aMorph openInWorld]]!
Item was added:
+ ----- Method: MorphicProject>>currentVocabulary (in category 'protocols') -----
+ currentVocabulary
+
+ ^ActiveWorld currentVocabulary!
Item was added:
+ ----- Method: MorphicProject>>defaultBackgroundColor (in category 'initialize') -----
+ defaultBackgroundColor
+ ^ Preferences uniformWindowColor!
Item was added:
+ ----- Method: MorphicProject>>displaySizeChanged (in category 'display') -----
+ displaySizeChanged
+ "Inform the current project that its display size has changed"
+ world restoreMorphicDisplay.
+ world repositionFlapsAfterScreenSizeChange.!
Item was added:
+ ----- Method: MorphicProject>>displayTranscripter: (in category 'transcripter') -----
+ displayTranscripter: transcripter
+ "A transcripter is a minimal user interface to support an emergency evaluator.
+ A Morphic project uses class NewParagraph."
+ transcripter morphicDisplayText!
Item was added:
+ ----- Method: MorphicProject>>do:withProgressInfoOn:label: (in category 'utilities') -----
+ do: aBlock withProgressInfoOn: aMorphOrNil label: aString
+ "Evaluate aBlock with a labeled progress bar"
+
+ ComplexProgressIndicator new
+ targetMorph: aMorphOrNil;
+ historyCategory: aString;
+ withProgressDo: aBlock
+ !
Item was added:
+ ----- Method: MorphicProject>>dockingBar (in category 'docking bars support') -----
+ dockingBar
+ ^ self
+ projectParameterAt: #dockingBar
+ ifAbsent: [ TheWorldMainDockingBar instance ]!
Item was added:
+ ----- Method: MorphicProject>>dockingBar: (in category 'docking bars support') -----
+ dockingBar: aTheWorldMainDockingBar
+ self
+ projectParameterAt: #dockingBar
+ put: aTheWorldMainDockingBar.
+ self isCurrentProject ifTrue: [ TheWorldMainDockingBar instance: aTheWorldMainDockingBar ]!
Item was added:
+ ----- Method: MorphicProject>>editCharacter:ofFont: (in category 'editors') -----
+ editCharacter: character ofFont: strikeFont
+ "Open a bit editor on a character in the given strike font."
+ "Note that BitEditor only works in MVC currently."
+
+ "(TextStyle default fontAt: 1) edit: $="
+
+ self inform: 'A Morphic editor has not been implemented. Enter an MVC project to edit this font.'!
Item was added:
+ ----- Method: MorphicProject>>enableDisableGlobalFlap: (in category 'flaps support') -----
+ enableDisableGlobalFlap: aFlapTab
+ "For the benefit of pre-existing which-global-flap buttons from a design now left behind."
+
+ self flag: #toRemove.
+ ^ self inform:
+ 'Sorry, this is an obsolete menu; please
+ dismiss it and get a fresh menu. Thanks.'.!
Item was added:
+ ----- Method: MorphicProject>>enterIfThereOrFind: (in category 'squeaklet on server') -----
+ enterIfThereOrFind: aProjectName
+
+ | newProject |
+ newProject := Project named: aProjectName.
+ newProject ifNotNil: [^newProject enter].
+
+ ComplexProgressIndicator new
+ targetMorph: nil;
+ historyCategory: 'project loading';
+ withProgressDo: [
+ [
+ newProject := self fromMyServerLoad: aProjectName
+ ]
+ on: ProjectViewOpenNotification
+ do: [ :ex | ex resume: false]
+ "we probably don't want a project view morph in this case"
+ ].
+
+ newProject ifNotNil: [^newProject enter].
+ Beeper beep.!
Item was added:
+ ----- Method: MorphicProject>>exportSegmentWithCatagories:classes:fileName:directory: (in category 'file in/out') -----
+ exportSegmentWithCatagories: catList classes: classList fileName: aFileName directory: aDirectory
+ "Store my project out on the disk as an *exported* ImageSegment. All outPointers will be in a form that can be resolved in the target image. Name it <project name>.extSeg. What do we do about subProjects, especially if they are out as local image segments? Force them to come in?
+ Player classes are included automatically."
+
+ | is str ans revertSeg roots holder |
+ self flag: #toRemove.
+ self halt. "unused"
+ "world == World ifTrue: [^ false]."
+ "self inform: 'Can''t send the current world out'."
+ world ifNil: [^ false]. world presenter ifNil: [^ false].
+
+ ScrapBook default emptyScrapBook.
+ world currentHand pasteBuffer: nil. "don't write the paste buffer."
+ world currentHand mouseOverHandler initialize. "forget about any references here"
+ "Display checkCurrentHandForObjectToPaste."
+ Command initialize.
+ world clearCommandHistory.
+ world fullReleaseCachedState; releaseViewers.
+ world cleanseStepList.
+ world localFlapTabs size = world flapTabs size ifFalse: [
+ self error: 'Still holding onto Global flaps'].
+ world releaseSqueakPages.
+ holder := Project allProjects. "force them in to outPointers, where DiskProxys are made"
+
+ "Just export me, not my previous version"
+ revertSeg := self parameterAt: #revertToMe.
+ self projectParameters removeKey: #revertToMe ifAbsent: [].
+
+ roots := OrderedCollection new.
+ roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail.
+ roots add: world activeHand; addAll: classList; addAll: (classList collect: [:cls | cls class]).
+
+ roots := roots reject: [ :x | x isNil]. "early saves may not have active hand or thumbnail"
+
+ catList do: [:sysCat |
+ (SystemOrganization listAtCategoryNamed: sysCat asSymbol) do: [:symb |
+ roots add: (Smalltalk at: symb); add: (Smalltalk at: symb) class]].
+
+ is := ImageSegment new copySmartRootsExport: roots asArray.
+ "old way was (is := ImageSegment new copyFromRootsForExport: roots asArray)"
+
+ is state = #tooBig ifTrue: [^ false].
+
+ str := ''.
+ "considered legal to save a project that has never been entered"
+ (is outPointers includes: world) ifTrue: [
+ str := str, '\Project''s own world is not in the segment.' withCRs].
+ str isEmpty ifFalse: [
+ ans := (UIManager default
+ chooseFrom: #('Do not write file' 'Write file anyway' 'Debug')
+ title: str).
+ ans = 1 ifTrue: [
+ revertSeg ifNotNil: [self projectParameterAt: #revertToMe put: revertSeg].
+ ^ false].
+ ans = 3 ifTrue: [self halt: 'Segment not written']].
+
+ is writeForExportWithSources: aFileName inDirectory: aDirectory.
+ revertSeg ifNotNil: [self projectParameterAt: #revertToMe put: revertSeg].
+ holder.
+ world flapTabs do: [:ft |
+ (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]].
+ is arrayOfRoots do: [:obj |
+ obj isScriptEditorMorph ifTrue: [obj unhibernate]].
+ ^ true
+ !
Item was added:
+ ----- Method: MorphicProject>>exportSegmentWithChangeSet:fileName:directory: (in category 'file in/out') -----
+ exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName
+ directory: aDirectory
+ "Store my project out on the disk as an *exported*
+ ImageSegment. All outPointers will be in a form that can be resolved
+ in the target image. Name it <project name>.extSeg. Whatdo we do
+ about subProjects, especially if they are out as local image
+ segments? Force them to come in?
+ Player classes are included automatically."
+
+ | is str ans revertSeg roots holder collector fd mgr stacks |
+
+ "Files out a changeSet first, so that a project can contain
+ its own classes"
+ world ifNil: [^ false]. world presenter ifNil: [^ false].
+
+ ScrapBook default emptyScrapBook.
+ world currentHand pasteBuffer: nil. "don't write the paste buffer."
+ world currentHand mouseOverHandler initialize. "forget about any
+ references here"
+ "Display checkCurrentHandForObjectToPaste."
+ Command initialize.
+ world clearCommandHistory.
+ world fullReleaseCachedState; releaseViewers.
+ world cleanseStepList.
+ world localFlapTabs size = world flapTabs size ifFalse: [
+ self error: 'Still holding onto Global flaps'].
+ world releaseSqueakPages.
+ holder := Project allProjects. "force them in to outPointers, where
+ DiskProxys are made"
+
+ "Just export me, not my previous version"
+ revertSeg := self parameterAt: #revertToMe.
+ self removeParameter: #revertToMe.
+
+ roots := OrderedCollection new.
+ roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail.
+ roots add: world activeHand.
+
+ "; addAll: classList; addAll: (classList collect: [:cls | cls class])"
+
+ roots := roots reject: [ :x | x isNil]. "early saves may not have
+ active hand or thumbnail"
+
+ fd := aDirectory directoryNamed: self resourceDirectoryName.
+ fd assureExistence.
+ "Clean up resource references before writing out"
+ mgr := self resourceManager.
+ self resourceManager: nil.
+ ResourceCollector current: ResourceCollector new.
+ ResourceCollector current localDirectory: fd.
+ ResourceCollector current baseUrl: self resourceUrl.
+ ResourceCollector current initializeFrom: mgr.
+ ProgressNotification signal: '2:findingResources' extra:
+ '(collecting resources...)' translated.
+ "Must activate old world because this is run at #armsLength.
+ Otherwise references to ActiveWorld, ActiveHand, or ActiveEvent
+ will not be captured correctly if referenced from blocks or user code."
+ world becomeActiveDuring:[
+ is := ImageSegment new copySmartRootsExport: roots asArray.
+ "old way was (is := ImageSegment new
+ copyFromRootsForExport: roots asArray)"
+ ].
+ self resourceManager: mgr.
+ collector := ResourceCollector current.
+ ResourceCollector current: nil.
+ ProgressNotification signal: '2:foundResources' extra: ''.
+ is state = #tooBig ifTrue: [
+ collector replaceAll.
+ ^ false].
+
+ str := ''.
+ "considered legal to save a project that has never been entered"
+ (is outPointers includes: world) ifTrue: [
+ str := str, '\Project''s own world is not in the segment.' translated withCRs].
+ str isEmpty ifFalse: [
+ ans := UIManager default chooseFrom: {
+ 'Do not write file' translated.
+ 'Write file anyway' translated.
+ 'Debug' translated.
+ } title: str.
+ ans = 1 ifTrue: [
+ revertSeg ifNotNil: [projectParameters at:
+ #revertToMe put: revertSeg].
+ collector replaceAll.
+ ^ false].
+ ans = 3 ifTrue: [
+ collector replaceAll.
+ self halt: 'Segment not written' translated]].
+ stacks := is findStacks.
+
+ is
+ writeForExportWithSources: aFileName
+ inDirectory: fd
+ changeSet: aChangeSetOrNil.
+ SecurityManager default signFile: aFileName directory: fd.
+ "Compress all files and update check sums"
+ collector forgetObsolete.
+ self storeResourceList: collector in: fd.
+ self storeHtmlPageIn: fd.
+ self storeManifestFileIn: fd.
+ self writeStackText: stacks in: fd registerIn: collector.
+ "local proj.005.myStack.t"
+ self compressFilesIn: fd to: aFileName in: aDirectory
+ resources: collector.
+ "also deletes the resource directory"
+ "Now update everything that we know about"
+ mgr updateResourcesFrom: collector.
+
+ revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
+ holder.
+
+ collector replaceAll.
+
+ world flapTabs do: [:ft |
+ (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]].
+ is arrayOfRoots do: [:obj |
+ obj isScriptEditorMorph ifTrue: [obj unhibernate]].
+ ^ true
+ !
Item was added:
+ ----- Method: MorphicProject>>finalEnterActions (in category 'enter') -----
+ finalEnterActions
+ "Perform the final actions necessary as the receiver project is entered"
+
+ | navigator armsLengthCmd navType thingsToUnhibernate |
+
+ self initializeMenus.
+ self projectParameters
+ at: #projectsToBeDeleted
+ ifPresent: [ :projectsToBeDeleted |
+ self removeParameter: #projectsToBeDeleted.
+ projectsToBeDeleted do: [ :each |
+ Project deletingProject: each.
+ each removeChangeSetIfPossible]].
+
+ Locale switchAndInstallFontToID: self localeID.
+
+ thingsToUnhibernate := world valueOfProperty: #thingsToUnhibernate ifAbsent: [#()].
+ thingsToUnhibernate do: [:each | each unhibernate].
+ world removeProperty: #thingsToUnhibernate.
+
+ navType := ProjectNavigationMorph preferredNavigator.
+ armsLengthCmd := self parameterAt: #armsLengthCmd ifAbsent: [nil].
+ navigator := world findA: navType.
+ (Preferences classicNavigatorEnabled and: [Preferences showProjectNavigator and: [navigator isNil]]) ifTrue:
+ [(navigator := navType new)
+ bottomLeft: world bottomLeft;
+ openInWorld: world].
+ navigator notNil & armsLengthCmd notNil ifTrue:
+ [navigator color: Color lightBlue].
+ armsLengthCmd notNil ifTrue:
+ [Preferences showFlapsWhenPublishing
+ ifFalse:
+ [self flapsSuppressed: true.
+ navigator ifNotNil: [navigator visible: false]].
+ armsLengthCmd openInWorld: world].
+ world reformulateUpdatingMenus.
+ world presenter positionStandardPlayer.
+ self assureMainDockingBarPresenceMatchesPreference.
+
+ WorldState addDeferredUIMessage: [self startResourceLoading].!
Item was added:
+ ----- Method: MorphicProject>>finalExitActions (in category 'enter') -----
+ finalExitActions
+
+ (world findA: ProjectNavigationMorph)
+ ifNotNil: [:navigator | navigator retractIfAppropriate].
+ uiProcess := nil. "forget the uiProcess that soon will be terminated"!
Item was added:
+ ----- Method: MorphicProject>>findAFolderForProject:label: (in category 'utilities') -----
+ findAFolderForProject: aProject label: dialogLabel
+ "Find a folder for saving or loading a project"
+
+ ^FileList2 modalFolderSelectorForProject: aProject
+ !
Item was added:
+ ----- Method: MorphicProject>>findProjectView: (in category 'utilities') -----
+ findProjectView: projectDescription
+ "In this world, find the morph that holds onto the project described by projectDescription.
+ projectDescription can be a project, or the name of a project. The project may be
+ represented by a DiskProxy. The holder morph may be at any depth in the world.."
+
+ | pName |
+ pName := (projectDescription isString)
+ ifTrue: [projectDescription]
+ ifFalse: [projectDescription name].
+ world allMorphsDo: [:pvm | | dpName |
+ pvm class == ProjectViewMorph ifTrue: [
+ (pvm project class == Project and:
+ [pvm project name = pName]) ifTrue: [^ pvm].
+ pvm project class == DiskProxy ifTrue: [
+ dpName := pvm project constructorArgs first.
+ dpName := (dpName findTokens: '/') last.
+ dpName := (Project parseProjectFileName: dpName unescapePercents) first.
+ dpName = pName ifTrue: [^ pvm]]]].
+ ^ nil!
Item was added:
+ ----- Method: MorphicProject>>flapsSuppressed: (in category 'flaps support') -----
+ flapsSuppressed: aBoolean
+ "Make the setting of the flag that governs whether global flaps are suppressed in the project be as indicated and add or remove the actual flaps"
+
+ super flapsSuppressed: aBoolean.
+ self == Project current
+ ifFalse: "Anomalous case where this project is not the current one."
+ [aBoolean
+ ifTrue:
+ [Flaps globalFlapTabsIfAny do:
+ [:aFlapTab | Flaps removeFlapTab: aFlapTab keepInList: true]]
+
+ ifFalse:
+ [Smalltalk isMorphic ifTrue:
+ [self currentWorld addGlobalFlaps]]].
+ Project current assureNavigatorPresenceMatchesPreference!
Item was added:
+ ----- Method: MorphicProject>>formEdit: (in category 'editors') -----
+ formEdit: aForm
+ "Start up an instance of the form editor on a form."
+
+ self inform: 'A Morphic editor has not been implemented. Enter an MVC project to edit this form or use #bitEdit'!
Item was added:
+ ----- Method: MorphicProject>>formViewClass (in category 'editors') -----
+ formViewClass
+ "Answer a class suitable for a view on a form or collection of forms"
+
+ ^ GraphicalDictionaryMenu!
Item was added:
+ ----- Method: MorphicProject>>future:do:at:args: (in category 'futures') -----
+ future: receiver do: aSelector at: deltaMSecs args: args
+ "Send a message deltaSeconds into the future. No response is expected."
+ | msg |
+ msg := MessageSend receiver: receiver selector: aSelector arguments: args.
+ deltaMSecs = 0
+ ifTrue: [self addDeferredUIMessage: msg]
+ ifFalse: [
+ world
+ addAlarm: #addDeferredUIMessage:
+ withArguments: {msg}
+ for: self
+ at: (Time millisecondClockValue + deltaMSecs)
+ ]..
+ ^nil!
Item was added:
+ ----- Method: MorphicProject>>future:send:at:args: (in category 'futures') -----
+ future: receiver send: aSelector at: deltaMSecs args: args
+ "Send a message deltaSeconds into the future. Answers a Promise that will be resolved at some time in the future."
+ | pr closure |
+ pr := Promise new.
+ closure := [pr resolveWith: (receiver perform: aSelector withArguments: args)].
+ deltaMSecs = 0
+ ifTrue: [self addDeferredUIMessage: closure]
+ ifFalse: [
+ world
+ addAlarm: #addDeferredUIMessage:
+ withArguments: {closure}
+ for: self
+ at: (Time millisecondClockValue + deltaMSecs)
+ ].
+ ^pr
+ !
Item was added:
+ ----- Method: MorphicProject>>globalFlapEnabledString: (in category 'flaps support') -----
+ globalFlapEnabledString: aFlapTab
+ "Answer the string to be shown in a menu to represent the status of the given flap regarding whether it it should be shown in this project."
+
+ ^ (self isFlapEnabled: aFlapTab)
+ ifTrue:
+ ['<on>', aFlapTab wording]
+ ifFalse:
+ ['<off>', aFlapTab wording]!
Item was added:
+ ----- Method: MorphicProject>>globalFlapWithIDEnabledString: (in category 'flaps support') -----
+ globalFlapWithIDEnabledString: aFlapID
+ "Answer the string to be shown in a menu to represent the status of the given flap regarding whether it it should be shown in this project."
+
+ | aFlapTab |
+ aFlapTab := Flaps globalFlapTabWithID: aFlapID.
+ ^ (self isFlapEnabled: aFlapTab)
+ ifTrue:
+ ['<on>', aFlapTab wording]
+ ifFalse:
+ ['<off>', aFlapTab wording]!
Item was added:
+ ----- Method: MorphicProject>>handleFatalDrawingError: (in category 'utilities') -----
+ handleFatalDrawingError: errMsg
+ "Handle a fatal drawing error."
+
+ Display deferUpdates: false. "Just in case"
+ self primitiveError: errMsg
+
+ "Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"!
Item was added:
+ ----- Method: MorphicProject>>initMorphic (in category 'initialize') -----
+ initMorphic
+ "Written so that Morphic can still be removed. Note that #initialize is never actually called for a morphic project -- see the senders of this method."
+
+ self flag: #toRemove. "check if this method still used by Etoys"
+ Smalltalk verifyMorphicAvailability ifFalse: [^ nil].
+ changeSet := ChangeSet new.
+ transcript := TranscriptStream new.
+ displayDepth := Display depth.
+ parentProject := CurrentProject.
+ world := PasteUpMorph newWorldForProject: self.
+ Locale switchToID: CurrentProject localeID.
+ self initializeProjectPreferences. "Do this *after* a world is installed so that the project will be recognized as a morphic one."
+ Preferences useVectorVocabulary ifTrue: [world installVectorVocabulary]!
Item was added:
+ ----- Method: MorphicProject>>initialize (in category 'initialize') -----
+ initialize
+ "Initialize a new Morphic Project"
+ super initialize.
+ world := PasteUpMorph newWorldForProject: self.
+ world color: self class defaultFill.
+ Locale switchToID: CurrentProject localeID.
+ Preferences useVectorVocabulary ifTrue: [world installVectorVocabulary]!
Item was added:
+ ----- Method: MorphicProject>>initializeMenus (in category 'enter') -----
+ initializeMenus
+ "Menu setting for these classes may have been modified by another
+ Morphic project, e.g. SimpleMorphic. Ensure that they are restored to the
+ expected menus."
+
+ Editor initialize.!
Item was added:
+ ----- Method: MorphicProject>>initializeParagraphForTranscripter: (in category 'transcripter') -----
+ initializeParagraphForTranscripter: transcripter
+ "A transcripter is a minimal user interface to support an emergency evaluator.
+ A Morphic project uses class NewParagraph."
+ transcripter morphicInitializeParagraph: NewParagraph!
Item was added:
+ ----- Method: MorphicProject>>installPasteUpAsWorld: (in category 'initialize') -----
+ installPasteUpAsWorld: pasteUpMorph
+ "(ProjectViewMorph newMorphicProjectOn: aPasteUpMorph) openInWorld."
+
+ world := pasteUpMorph beWorldForProject: self!
Item was added:
+ ----- Method: MorphicProject>>interruptName: (in category 'scheduling') -----
+ interruptName: labelString
+ "Create a Notifier on the active scheduling process with the given label."
+
+ ^ self interruptName: labelString preemptedProcess: nil!
Item was added:
+ ----- Method: MorphicProject>>interruptName:preemptedProcess: (in category 'utilities') -----
+ interruptName: labelString preemptedProcess: theInterruptedProcess
+ "Create a Notifier on the active scheduling process with the given label."
+
+ | preemptedProcess projectProcess |
+ ActiveHand ifNotNil:[ActiveHand interrupted].
+ ActiveWorld := World. "reinstall active globals"
+ ActiveHand := World primaryHand.
+ ActiveHand interrupted. "make sure this one's interrupted too"
+ ActiveEvent := nil.
+
+ projectProcess := self uiProcess. "we still need the accessor for a while"
+ preemptedProcess := theInterruptedProcess ifNil: [Processor preemptedProcess].
+ "Only debug preempted process if its priority is >= projectProcess' priority"
+ preemptedProcess priority < projectProcess priority
+ ifTrue:[preemptedProcess := projectProcess].
+ preemptedProcess suspend.
+ ToolSet interrupt: preemptedProcess label: labelString.!
Item was added:
+ ----- Method: MorphicProject>>invalidate (in category 'display') -----
+ invalidate
+ "Invalidate the entire project so that a redraw will be forced later."
+ world fullRepaintNeeded.!
Item was added:
+ ----- Method: MorphicProject>>isFlapEnabled: (in category 'flaps support') -----
+ isFlapEnabled: aFlapTab
+ "Answer whether the given flap tab is enabled in this project"
+
+ ^ self isFlapIDEnabled: aFlapTab flapID!
Item was added:
+ ----- Method: MorphicProject>>isFlapIDEnabled: (in category 'flaps support') -----
+ isFlapIDEnabled: aFlapID
+ "Answer whether a flap of the given ID is enabled in this project"
+
+ | disabledFlapIDs |
+ disabledFlapIDs := self parameterAt: #disabledGlobalFlapIDs ifAbsent: [^ true].
+ ^ (disabledFlapIDs includes: aFlapID) not!
Item was added:
+ ----- Method: MorphicProject>>isIncompletelyLoaded (in category 'enter') -----
+ isIncompletelyLoaded
+ "Answer true if project is incomplete and should be loaded from server "
+
+ (world isKindOf: StringMorph)
+ ifTrue: [self inform: 'This project is not all here. I will try to load a complete version.' translated.
+ ^ true].
+ ^ false!
Item was added:
+ ----- Method: MorphicProject>>isMorphic (in category 'testing') -----
+ isMorphic
+ "Duh."
+ ^true!
Item was added:
+ ----- Method: MorphicProject>>jumpToProject (in category 'utilities') -----
+ jumpToProject
+ "Present a list of potential projects and enter the one selected."
+
+ "Project current jumpToProject"
+
+ | menu |
+ menu:=MenuMorph new.
+ menu defaultTarget: self.
+ menu := self buildJumpToMenu: menu.
+ menu popUpInWorld!
Item was added:
+ ----- Method: MorphicProject>>loadFromServer: (in category 'file in/out') -----
+ loadFromServer: newerAutomatically
+ "If a newer version of me is on the server, load it."
+ | pair resp server |
+ self assureIntegerVersion.
+
+ self isCurrentProject ifTrue: ["exit, then do the command"
+ ^ self armsLengthCommand: #loadFromServer withDescription: 'Loading' translated
+ ].
+ server := self tryToFindAServerWithMe ifNil: [^ nil].
+ pair := self class mostRecent: self name onServer: server.
+ pair first ifNil: [^ self inform: ('can''t find file on server for {1}' translated format: {self name})].
+ self currentVersionNumber > pair second ifTrue: [
+ ^ self inform: ('That server has an older version of the project.' translated)].
+ version = (Project parseProjectFileName: pair first) second ifTrue: [
+ resp := (UIManager default chooseFrom:
+ (Array with: 'Reload anyway' translated
+ with: 'Cancel' translated withCRs)
+ title: 'The only changes are the ones you made here.' translated).
+ resp ~= 1 ifTrue: [^ nil]
+ ] ifFalse: [
+ newerAutomatically ifFalse: [
+ resp := (UIManager default
+ chooseFrom: #('Load it' 'Cancel')
+ title: 'A newer version exists on the server.').
+ resp ~= 1 ifTrue: [^ nil]
+ ].
+ ].
+
+ "let's avoid renaming the loaded change set since it will be replacing ours"
+ self projectParameters at: #loadingNewerVersion put: true.
+
+ ComplexProgressIndicator new
+ targetMorph: nil;
+ historyCategory: 'project loading';
+ withProgressDo: [
+ ProjectLoading
+ installRemoteNamed: pair first
+ from: server
+ named: self name
+ in: parentProject
+ ]
+ !
Item was added:
+ ----- Method: MorphicProject>>makeThumbnail (in category 'menu messages') -----
+ makeThumbnail
+ "Make a thumbnail image of this project from the Display."
+ world displayWorldSafely. "clean pending damage"
+ super makeThumbnail.!
Item was added:
+ ----- Method: MorphicProject>>noteManifestDetailsIn: (in category 'file in/out') -----
+ noteManifestDetailsIn: manifestInfo
+ "The receiver is a project being loaded. From the dictionary provided, absorb and remember whether it's an 'old' (pre-olpc) project, and remember the GUID, user, and prev-GUID associated with the project when these data are available in the incoming manifest."
+
+ | manifestDict oldProject |
+ manifestInfo isEmptyOrNil ifTrue: [^ self projectParameterAt: #oldProject put: true].
+
+ manifestDict := (manifestInfo isKindOf: Dictionary) ifTrue: [manifestInfo] ifFalse: [manifestInfo first].
+
+ oldProject := ((manifestDict at: 'Squeak-Version' ifAbsent: ['']) beginsWith: 'etoys') not.
+ self projectParameterAt: #oldProject put: oldProject.
+
+ manifestDict at: #URI ifPresent: [:aUri | self projectParameterAt: #URI put: aUri].
+ manifestDict at: #user ifPresent: [:aUser | self projectParameterAt: #user put: aUser].
+ manifestDict at: #'prev-URI' ifPresent: [:aUri | self projectParameterAt: #'prev-URI' put: aUri]!
Item was added:
+ ----- Method: MorphicProject>>offerMenu:from:shifted: (in category 'utilities') -----
+ offerMenu: menuSelector from: aModel shifted: aBoolean
+ "Pop up a menu whose target is aModel and whose contents are provided
+ by sending the menuSelector to the model. The menuSelector takes two
+ arguments: a menu, and a boolean representing the shift state."
+
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: aModel.
+ aModel perform: menuSelector with: aMenu with: aBoolean.
+ aMenu popUpInWorld
+ !
Item was added:
+ ----- Method: MorphicProject>>openBlankProjectNamed: (in category 'squeaklet on server') -----
+ openBlankProjectNamed: projName
+
+ | proj projViewer |
+
+ proj := MorphicProject openViewOn: nil.
+ proj changeSet name: projName.
+ proj world addMorph: (
+ TextMorph new
+ beAllFont: ((TextStyle default fontOfSize: 26) emphasized: 1);
+ color: Color red;
+ contents: 'Welcome to a new project - ',projName
+ ).
+ proj setParent: self.
+ projViewer := (self findProjectView: projName) ifNil: [^proj].
+ (projViewer owner isSystemWindow) ifTrue: [
+ projViewer owner model: proj].
+ ^ projViewer project: proj!
Item was added:
+ ----- Method: MorphicProject>>openImage:name:saveResource: (in category 'editors') -----
+ openImage: aForm name: fullName saveResource: aBoolean
+ "Open a view on an image. If aBoolean is true, save the image as a project resource."
+
+ aBoolean ifTrue:
+ [self resourceManager
+ addResource: aForm
+ url: (FileDirectory urlForFileNamed: fullName) asString].
+ (World drawingClass withForm: aForm) openInWorld
+ !
Item was added:
+ ----- Method: MorphicProject>>openProject: (in category 'initialize') -----
+ openProject: aProject
+ "Create a new for a new project in the context of the receiver"
+ ProjectViewMorph openOn: aProject.!
Item was added:
+ ----- Method: MorphicProject>>pauseEventRecorder (in category 'enter') -----
+ pauseEventRecorder
+ "Suspend any event recorder, and return it if found"
+
+ ^World pauseEventRecorder!
Item was added:
+ ----- Method: MorphicProject>>pauseSoundPlayers (in category 'enter') -----
+ pauseSoundPlayers
+ "Pause sound players, subject to preference settings"
+
+ (world hasProperty: #letTheMusicPlay)
+ ifTrue: [world removeProperty: #letTheMusicPlay]
+ ifFalse: [Smalltalk at: #ScorePlayer ifPresent:
+ [:playerClass | playerClass allSubInstancesDo:
+ [:player | player pause]]]
+ !
Item was added:
+ ----- Method: MorphicProject>>pointerMoved (in category 'utilities') -----
+ pointerMoved
+ "Pointer has moved during a drag operation. Perform any necessary updates.
+ In Morphic, pay the price for reading the sensor directly."
+
+ World activeHand
+ newMouseFocus: nil;
+ showTemporaryCursor: nil;
+ flushEvents!
Item was added:
+ ----- Method: MorphicProject>>prepareForDelete (in category 'release') -----
+ prepareForDelete
+ "The window in which the project is housed is about to deleted. Perform
+ any necessary actions to prepare for deletion."
+
+ | is list |
+ Smalltalk at: #WonderlandCameraMorph ifPresent:[:aClass |
+ world submorphs do: "special release for wonderlands"
+ [:m | (m isKindOf: aClass)
+ and: [m getWonderland release]]].
+ "Remove Player classes and metaclasses owned by project"
+ is := ImageSegment new arrayOfRoots: (Array with: self).
+ (list := is rootsIncludingPlayers) ifNotNil:
+ [list do: [:playerCls |
+ (playerCls respondsTo: #isMeta) ifTrue:
+ [playerCls isMeta ifFalse:
+ [playerCls removeFromSystemUnlogged]]]]
+
+ !
Item was added:
+ ----- Method: MorphicProject>>removeMainDockingBar (in category 'docking bars support') -----
+ removeMainDockingBar
+ "Remove the receiver's main docking bars"
+ self world mainDockingBars
+ do: [:each | each delete]!
Item was added:
+ ----- Method: MorphicProject>>resetDisplay (in category 'display') -----
+ resetDisplay
+ "Bring the display to a usable state after handling primitiveError."
+
+ World install "init hands and redisplay"!
Item was added:
+ ----- Method: MorphicProject>>restore (in category 'display') -----
+ restore
+ world fullDrawOn: Display getCanvas.
+ !
Item was added:
+ ----- Method: MorphicProject>>restoreDisplay (in category 'display') -----
+ restoreDisplay
+ "Clear the screen to gray and then redisplay all the scheduled views."
+
+ ^ World restoreMorphicDisplay
+ !
Item was added:
+ ----- Method: MorphicProject>>saveState (in category 'enter') -----
+ saveState
+ "Save the current state in me prior to leaving this project"
+
+ changeSet := ChangeSet current.
+ thumbnail ifNotNil: [thumbnail hibernate].
+ world := World.
+ world sleep.
+ ActiveWorld := ActiveHand := ActiveEvent := nil.
+ Sensor flushAllButDandDEvents. "Will be reinstalled by World>>install"
+ transcript := Transcript
+ !
Item was added:
+ ----- Method: MorphicProject>>scheduleProcessForEnter: (in category 'enter') -----
+ scheduleProcessForEnter: showZoom
+ "Complete the enter: by launching a new process"
+
+ self finalEnterActions.
+ world repairEmbeddedWorlds.
+ world triggerEvent: #aboutToEnterWorld.
+ Project current spawnNewProcessAndTerminateOld: true
+ !
Item was added:
+ ----- Method: MorphicProject>>selectorPrefixForDispatch (in category 'dispatching') -----
+ selectorPrefixForDispatch
+ "A string to be prepended to selectors for project specific methods"
+
+ ^ 'morphic'!
Item was added:
+ ----- Method: MorphicProject>>setAsBackground: (in category 'utilities') -----
+ setAsBackground: aForm
+ "Set aForm as a background image."
+
+ | thisWorld newColor |
+ thisWorld := self currentWorld.
+ newColor := InfiniteForm with: aForm.
+ aForm rememberCommand:
+ (Command new cmdWording: 'set background to a picture' translated;
+ undoTarget: thisWorld selector: #color: argument: thisWorld color;
+ redoTarget: thisWorld selector: #color: argument: newColor).
+ thisWorld color: newColor
+ !
Item was added:
+ ----- Method: MorphicProject>>setFlaps (in category 'flaps support') -----
+ setFlaps
+
+ | flapTabs flapIDs sharedFlapTabs navigationMorph |
+ self flag: #toRemove. "check if this method still used by Etoys"
+
+ flapTabs := ActiveWorld flapTabs.
+ flapIDs := flapTabs collect: [:tab | tab knownName].
+ flapTabs
+ do: [:tab | (tab isMemberOf: ViewerFlapTab)
+ ifFalse: [tab isGlobalFlap
+ ifTrue: [Flaps removeFlapTab: tab keepInList: false.
+ tab currentWorld reformulateUpdatingMenus]
+ ifFalse: [| referent |
+ referent := tab referent.
+ referent isInWorld
+ ifTrue: [referent delete].
+ tab delete]]].
+ sharedFlapTabs := Flaps classPool at: #SharedFlapTabs.
+ flapIDs
+ do: [:id |
+ id = 'Navigator' translated
+ ifTrue: [sharedFlapTabs add: Flaps newNavigatorFlap].
+ id = 'Widgets' translated
+ ifTrue: [sharedFlapTabs add: Flaps newWidgetsFlap].
+ id = 'Tools' translated
+ ifTrue: [sharedFlapTabs add: Flaps newToolsFlap].
+ id = 'Squeak' translated
+ ifTrue: [sharedFlapTabs add: Flaps newSqueakFlap].
+ id = 'Supplies' translated
+ ifTrue: [sharedFlapTabs add: Flaps newSuppliesFlap].
+ id = 'Stack Tools' translated
+ ifTrue: [sharedFlapTabs add: Flaps newStackToolsFlap].
+ id = 'Painting' translated
+ ifTrue: [sharedFlapTabs add: Flaps newPaintingFlap].
+ id = 'Objects' translated
+ ifTrue: [sharedFlapTabs add: Flaps newObjectsFlap ]].
+ 2 timesRepeat: [flapIDs do: [:id | Flaps enableDisableGlobalFlapWithID: id]].
+ ActiveWorld flapTabs
+ do: [:flapTab | flapTab isCurrentlyTextual
+ ifTrue: [flapTab changeTabText: flapTab knownName]].
+ Flaps positionNavigatorAndOtherFlapsAccordingToPreference.
+ navigationMorph := World findDeeplyA: ProjectNavigationMorph preferredNavigator.
+ navigationMorph isNil
+ ifTrue: [^ self].
+ navigationMorph allMorphs
+ do: [:morph | morph class == SimpleButtonDelayedMenuMorph
+ ifTrue: [(morph findA: ImageMorph) isNil
+ ifTrue: [| label |
+ label := morph label.
+ label isNil
+ ifFalse: [| name |
+ name := morph knownName.
+ name isNil
+ ifTrue: [morph name: label.
+ name := label].
+ morph label: name translated]]]]!
Item was added:
+ ----- Method: MorphicProject>>setWorldForEmergencyRecovery (in category 'enter') -----
+ setWorldForEmergencyRecovery
+ "Prepare world for enter with an absolute minimum of mechanism.
+ An unrecoverable error has been detected in an isolated project."
+
+ World := world.
+ world install.
+ world triggerOpeningScripts
+ !
Item was added:
+ ----- Method: MorphicProject>>setWorldForEnterFrom:recorder: (in category 'enter') -----
+ setWorldForEnterFrom: old recorder: recorderOrNil
+ "Prepare world for enter."
+
+ World := world. "Signifies Morphic"
+ world install.
+ world transferRemoteServerFrom: old world.
+ "(revertFlag | saveForRevert | forceRevert) ifFalse: [
+ (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [
+ self storeSomeSegment]]."
+ recorderOrNil ifNotNil: [recorderOrNil resumeIn: world].
+ world triggerOpeningScripts
+ !
Item was added:
+ ----- Method: MorphicProject>>showImage:named: (in category 'utilities') -----
+ showImage: aForm named: imageName
+ "Show an image, possibly attached to the pointer for positioning"
+
+ HandMorph attach: (World drawingClass withForm: aForm)
+ !
Item was added:
+ ----- Method: MorphicProject>>showWorldMainDockingBar (in category 'docking bars support') -----
+ showWorldMainDockingBar
+
+ ^ self projectPreferenceFlagDictionary
+ at: #showWorldMainDockingBar
+ ifAbsent: [ false ]!
Item was added:
+ ----- Method: MorphicProject>>showWorldMainDockingBar: (in category 'docking bars support') -----
+ showWorldMainDockingBar: aBoolean
+ "Change the receiver to show the main docking bar"
+ self projectPreferenceFlagDictionary at: #showWorldMainDockingBar put: aBoolean.
+ (self == Project current
+ and: [aBoolean ~= Preferences showWorldMainDockingBar])
+ ifTrue: [Preferences setPreference: #showWorldMainDockingBar toValue: aBoolean].
+ self assureMainDockingBarPresenceMatchesPreference!
Item was added:
+ ----- Method: MorphicProject>>showWorldMainDockingBarString (in category 'docking bars support') -----
+ showWorldMainDockingBarString
+ ^ (self showWorldMainDockingBar
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ , 'show main docking bar (M)' translated!
Item was added:
+ ----- Method: MorphicProject>>spawnNewProcess (in category 'active process') -----
+ spawnNewProcess
+
+ uiProcess := [
+ [World doOneCycle. Processor yield ] repeat.
+ ] newProcess priority: Processor userSchedulingPriority.
+ uiProcess resume!
Item was added:
+ ----- Method: MorphicProject>>spawnNewProcessAndTerminateOld: (in category 'active process') -----
+ spawnNewProcessAndTerminateOld: terminate
+
+ self spawnNewProcess.
+ terminate
+ ifTrue: [Processor terminateActive]
+ ifFalse: [Processor activeProcess suspend]!
Item was added:
+ ----- Method: MorphicProject>>spawnNewProcessIfThisIsUI: (in category 'active process') -----
+ spawnNewProcessIfThisIsUI: suspendedProcess
+ "Initialize a UI process if needed. Answer true if suspendedProcess was interrupted
+ from a UI process."
+ self uiProcess == suspendedProcess ifTrue: [
+ self spawnNewProcess.
+ ^true
+ ].
+ ^false "no new process was created"
+ !
Item was added:
+ ----- Method: MorphicProject>>storeSegment (in category 'file in/out') -----
+ storeSegment
+ "Store my project out on the disk as an ImageSegment. Keep the outPointers in memory. Name it <project name>.seg. *** Caller must be holding (Project alInstances) to keep subprojects from going out. ***"
+
+ | is sizeHint |
+ (World == world) ifTrue: [^ false].
+ "self inform: 'Can''t send the current world out'."
+ world isInMemory ifFalse: [^ false]. "already done"
+ world ifNil: [^ false]. world presenter ifNil: [^ false].
+
+ ScrapBook default emptyScrapBook.
+ World checkCurrentHandForObjectToPaste.
+ world releaseSqueakPages.
+ sizeHint := self projectParameters at: #segmentSize ifAbsent: [0].
+
+ is := ImageSegment new copyFromRootsLocalFileFor:
+ (Array with: world presenter with: world) "world, and all Players"
+ sizeHint: sizeHint.
+
+ is state = #tooBig ifTrue: [^ false].
+ is segment size < 2000 ifTrue: ["debugging"
+ Transcript show: self name, ' only ', is segment size printString,
+ 'bytes in Segment.'; cr].
+ self projectParameters at: #segmentSize put: is segment size.
+ is extract; writeToFile: self name.
+ ^ true
+ !
Item was added:
+ ----- Method: MorphicProject>>storeSegmentNoFile (in category 'file in/out') -----
+ storeSegmentNoFile
+ "For testing. Make an ImageSegment. Keep the outPointers in memory. Also useful if you want to enumerate the objects in the segment afterwards (allObjectsDo:)"
+
+ | is |
+ (World == world) ifTrue: [^ self]. " inform: 'Can''t send the current world out'."
+ world isInMemory ifFalse: [^ self]. "already done"
+ world ifNil: [^ self]. world presenter ifNil: [^ self].
+
+ "Do this on project enter"
+ World flapTabs do: [:ft | ft referent adaptToWorld: World].
+ "Hack to keep the Menu flap from pointing at my project"
+ "Preferences setPreference: #useGlobalFlaps toValue: false."
+ "Utilities globalFlapTabsIfAny do:
+ [:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: false].
+ Utilities clobberFlapTabList. "
+ "project world deleteAllFlapArtifacts."
+ "self currentWorld deleteAllFlapArtifacts. "
+ ScrapBook default emptyScrapBook.
+ World checkCurrentHandForObjectToPaste2.
+
+ is := ImageSegment new copyFromRootsLocalFileFor:
+ (Array with: world presenter with: world) "world, and all Players"
+ sizeHint: 0.
+
+ is segment size < 800 ifTrue: ["debugging"
+ Transcript show: self name, ' did not get enough objects'; cr. ^ Beeper beep].
+
+ is extract.
+ "is instVarAt: 2 put: is segment clone." "different memory"
+ !
Item was added:
+ ----- Method: MorphicProject>>subProjects (in category 'utilities') -----
+ subProjects
+ "Answer a list of all the subprojects of the receiver. "
+ ^world submorphs
+ select: [:m | (m isSystemWindow) and: [m model isKindOf: Project]]
+ thenCollect: [:m | m model].!
Item was added:
+ ----- Method: MorphicProject>>suppressFlapsString (in category 'flaps support') -----
+ suppressFlapsString
+ ^ (self flapsSuppressed
+ ifTrue: ['<no>']
+ ifFalse: ['<yes>']), 'show shared tabs (F)' translated!
Item was added:
+ ----- Method: MorphicProject>>textWindows (in category 'utilities') -----
+ textWindows
+ "Answer a dictionary of all system windows for text display keyed by window title.
+ Generate new window titles as required to ensure unique keys in the dictionary."
+
+ | aDict windows title |
+ aDict := Dictionary new.
+ windows := World submorphs select: [:m | m isSystemWindow].
+ windows do:
+ [:w | | assoc |
+ assoc := w titleAndPaneText.
+ assoc ifNotNil:
+ [w holdsTranscript ifFalse:
+ [title := assoc key.
+ (aDict includesKey: title) ifTrue: [ | newKey | "Ensure unique keys in aDict"
+ (1 to: 100) detect: [:e |
+ newKey := title, '-', e asString.
+ (aDict includesKey: newKey) not].
+ title := newKey.
+ assoc := newKey -> assoc value].
+ aDict add: assoc]]].
+ ^ aDict
+ !
Item was added:
+ ----- Method: MorphicProject>>toggleFlapsSuppressed (in category 'flaps support') -----
+ toggleFlapsSuppressed
+ "Project current toggleFlapsSuppressed"
+
+ ^self flapsSuppressed: self flapsSuppressed not.!
Item was added:
+ ----- Method: MorphicProject>>toggleShowWorldMainDockingBar (in category 'docking bars support') -----
+ toggleShowWorldMainDockingBar
+ self showWorldMainDockingBar: self showWorldMainDockingBar not!
Item was added:
+ ----- Method: MorphicProject>>triggerClosingScripts (in category 'enter') -----
+ triggerClosingScripts
+ "If any scripts must be run on closing, run them now"
+
+ CurrentProject world triggerClosingScripts
+ !
Item was added:
+ ----- Method: MorphicProject>>uiProcess (in category 'active process') -----
+ uiProcess
+ ^uiProcess!
Item was added:
+ ----- Method: MorphicProject>>uiProcess: (in category 'active process') -----
+ uiProcess: newUIProcess
+ ^uiProcess := newUIProcess!
Item was added:
+ ----- Method: MorphicProject>>viewLocFor: (in category 'display') -----
+ viewLocFor: exitedProject
+ "Look for a view of the exitedProject, and return its center"
+
+ world submorphsDo: [:v |
+ (v isSystemWindow and: [v model == exitedProject])
+ ifTrue: [^ v center]].
+ ^ Sensor cursorPoint "default result"!
Item was added:
+ ----- Method: MorphicProject>>wakeUpTopWindow (in category 'enter') -----
+ wakeUpTopWindow
+ "Image has been restarted, and the startUp list has been processed. Perform
+ any additional actions needed to restart the user interface."
+
+ SystemWindow wakeUpTopWindowUponStartup!
Item was added:
+ MorphicEvent subclass: #MorphicUnknownEvent
+ instanceVariableNames: 'type argument'
+ classVariableNames: ''
+ poolDictionaries: 'EventSensorConstants'
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: MorphicUnknownEvent>>argument (in category 'accessing') -----
+ argument
+ ^argument!
Item was added:
+ ----- Method: MorphicUnknownEvent>>argument: (in category 'accessing') -----
+ argument: arg
+ argument := arg!
Item was added:
+ ----- Method: MorphicUnknownEvent>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ type ifNil: [type := #startSound].
+ source ifNil: [source := varDict at: 'sourceHand'].
+ argument ifNil: [argument := varDict at: 'sound' ifAbsent: [nil]]. "???"
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: MorphicUnknownEvent>>position (in category 'accessing') -----
+ position
+ ^0 at 0!
Item was added:
+ ----- Method: MorphicUnknownEvent>>setType:argument: (in category 'private') -----
+ setType: evtType argument: arg
+ type := evtType.
+ argument := arg.!
Item was added:
+ ----- Method: MorphicUnknownEvent>>setType:argument:hand:stamp: (in category 'private') -----
+ setType: evtType argument: arg hand: evtHand stamp: stamp
+ type := evtType.
+ argument := arg.
+ source := evtHand.
+ timeStamp := stamp.!
Item was added:
+ ----- Method: MorphicUnknownEvent>>storeOn: (in category 'printing') -----
+ storeOn: aStream
+ aStream nextPutAll: 'unknown'.
+ aStream space.
+ self timeStamp storeOn: aStream.
+ aStream space.
+ {type. argument} storeOn: aStream.!
Item was added:
+ ----- Method: MorphicUnknownEvent>>type (in category 'accessing') -----
+ type
+ ^type!
Item was added:
+ ----- Method: MorphicUnknownEvent>>type:readFrom: (in category 'initialize') -----
+ type: eventType readFrom: aStream
+ | typeAndArg |
+ timeStamp := Integer readFrom: aStream.
+ aStream skip: 1.
+ typeAndArg := Object readFrom: aStream.
+ type := typeAndArg first.
+ argument := typeAndArg last.!
Item was added:
+ MouseEvent subclass: #MouseButtonEvent
+ instanceVariableNames: 'whichButton'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: MouseButtonEvent>>blueButtonChanged (in category 'accessing') -----
+ blueButtonChanged
+ "Answer true if the blue mouse button has changed. This is the third mouse button or cmd+click on the Mac."
+
+ ^ whichButton anyMask: 1!
Item was added:
+ ----- Method: MouseButtonEvent>>redButtonChanged (in category 'accessing') -----
+ redButtonChanged
+ "Answer true if the red mouse button has changed. This is the first mouse button."
+
+ ^ whichButton anyMask: 4!
Item was added:
+ ----- Method: MouseButtonEvent>>sentTo: (in category 'dispatching') -----
+ sentTo: anObject
+ "Dispatch the receiver into anObject"
+ type == #mouseDown ifTrue:[^anObject handleMouseDown: self].
+ type == #mouseUp ifTrue:[^anObject handleMouseUp: self].
+ ^super sentTo: anObject!
Item was added:
+ ----- Method: MouseButtonEvent>>setType:position:which:buttons:hand:stamp: (in category 'private') -----
+ setType: evtType position: evtPos which: button buttons: evtButtons hand: evtHand stamp: stamp
+ type := evtType.
+ position := evtPos.
+ buttons := evtButtons.
+ source := evtHand.
+ wasHandled := false.
+ whichButton := button.
+ timeStamp := stamp.!
Item was added:
+ ----- Method: MouseButtonEvent>>storeOn: (in category 'printing') -----
+ storeOn: aStream
+ super storeOn: aStream.
+ aStream space.
+ whichButton storeOn: aStream.!
Item was added:
+ ----- Method: MouseButtonEvent>>type:readFrom: (in category 'initialize') -----
+ type: eventType readFrom: aStream
+ super type: eventType readFrom: aStream.
+ aStream skip: 1.
+ whichButton := Integer readFrom: aStream.!
Item was added:
+ ----- Method: MouseButtonEvent>>whichButton (in category 'accessing') -----
+ whichButton
+ ^whichButton!
Item was added:
+ ----- Method: MouseButtonEvent>>yellowButtonChanged (in category 'accessing') -----
+ yellowButtonChanged
+ "Answer true if the yellow mouse button has changed. This is the second mouse button or option+click on the Mac."
+
+ ^ whichButton anyMask: 2!
Item was added:
+ Object subclass: #MouseClickState
+ instanceVariableNames: 'clickClient clickState firstClickDown firstClickUp firstClickTime clickSelector dblClickSelector dblClickTime dblClickTimeoutSelector dragSelector dragThreshold'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Kernel'!
+
+ !MouseClickState commentStamp: '<historical>' prior: 0!
+ MouseClickState is a simple class managing the distinction between clicks, double clicks, and drag operations. It has been factored out of HandMorph due to the many instVars.
+
+ Instance variables:
+ clickClient <Morph> The client wishing to receive #click:, #dblClick:, or #drag messages
+ clickState <Symbol> The internal state of handling the last event (#firstClickDown, #firstClickUp, #firstClickTimedOut)
+ firstClickDown <MorphicEvent> The #mouseDown event after which the client wished to receive #click: or similar messages
+ firstClickUp <MorphicEvent> The first mouse up event which came in before the double click time out was exceeded (it is sent if there is a timout after the first mouse up event occured)
+ firstClickTime <Integer> The millisecond clock value of the first event
+ clickSelector <Symbol> The selector to use for sending #click: messages
+ dblClickSelector <Symbol> The selector to use for sending #doubleClick: messages
+ dblClickTime <Integer> Timout in milliseconds for a double click operation
+ dragSelector <Symbol> The selector to use for sending #drag: messages
+ dragThreshold <Integer> Threshold used for determining if a #drag: message is sent (pixels!!)
+ !
Item was added:
+ ----- Method: MouseClickState>>click (in category 'event handling') -----
+ click
+
+ clickSelector ifNotNil: [clickClient perform: clickSelector with: firstClickDown]!
Item was added:
+ ----- Method: MouseClickState>>client:click:dblClick:dblClickTime:dblClickTimeout:drag:threshold:event: (in category 'initialize') -----
+ client: aMorph click: aClickSelector dblClick: aDblClickSelector dblClickTime: timeOut dblClickTimeout: aDblClickTimeoutSelector drag: aDragSelector threshold: aNumber event: firstClickEvent
+ clickClient := aMorph.
+ clickSelector := aClickSelector.
+ dblClickSelector := aDblClickSelector.
+ dblClickTime := timeOut.
+ dblClickTimeoutSelector := aDblClickTimeoutSelector.
+ dragSelector := aDragSelector.
+ dragThreshold := aNumber.
+ firstClickDown := firstClickEvent.
+ firstClickTime := firstClickEvent timeStamp.
+ clickState := #firstClickDown.!
Item was added:
+ ----- Method: MouseClickState>>doubleClick (in category 'event handling') -----
+ doubleClick
+
+ dblClickSelector ifNotNil: [clickClient perform: dblClickSelector with: firstClickDown]!
Item was added:
+ ----- Method: MouseClickState>>doubleClickTimeout (in category 'event handling') -----
+ doubleClickTimeout
+
+ dblClickTimeoutSelector ifNotNil: [
+ clickClient perform: dblClickTimeoutSelector with: firstClickDown]!
Item was added:
+ ----- Method: MouseClickState>>drag: (in category 'event handling') -----
+ drag: event
+
+ dragSelector ifNotNil: [clickClient perform: dragSelector with: event]!
Item was added:
+ ----- Method: MouseClickState>>handleEvent:from: (in category 'event handling') -----
+ handleEvent: evt from: aHand
+ "Process the given mouse event to detect a click, double-click, or drag.
+ Return true if the event should be processed by the sender, false if it shouldn't.
+ NOTE: This method heavily relies on getting *all* mouse button events."
+ | localEvt timedOut isDrag |
+ timedOut := (evt timeStamp - firstClickTime) > dblClickTime.
+ localEvt := evt transformedBy: (clickClient transformedFrom: aHand owner).
+ isDrag := (localEvt position - firstClickDown position) r > dragThreshold.
+ clickState == #firstClickDown ifTrue: [
+ "Careful here - if we had a slow cycle we may have a timedOut mouseUp event"
+ (timedOut and:[localEvt isMouseUp not]) ifTrue:[
+ "timeout before #mouseUp -> keep waiting for drag if requested"
+ clickState := #firstClickTimedOut.
+ dragSelector ifNil:[
+ aHand resetClickState.
+ self doubleClickTimeout; click "***"].
+ ^true].
+ localEvt isMouseUp ifTrue:[
+
+ (timedOut or:[dblClickSelector isNil]) ifTrue:[
+ self click.
+ aHand resetClickState.
+ ^true].
+ "Otherwise transfer to #firstClickUp"
+ firstClickUp := evt copy.
+ clickState := #firstClickUp.
+ "If timedOut or the client's not interested in dbl clicks get outta here"
+ self click.
+ aHand handleEvent: firstClickUp.
+ ^false].
+ isDrag ifTrue:["drag start"
+ self doubleClickTimeout. "***"
+ aHand resetClickState.
+ dragSelector "If no drag selector send #click instead"
+ ifNil: [self click]
+ ifNotNil: [self drag: firstClickDown].
+ ^true].
+ ^false].
+
+ clickState == #firstClickTimedOut ifTrue:[
+ localEvt isMouseUp ifTrue:["neither drag nor double click"
+ aHand resetClickState.
+ self doubleClickTimeout; click. "***"
+ ^true].
+ isDrag ifTrue:["drag start"
+ aHand resetClickState.
+ self doubleClickTimeout; drag: firstClickDown. "***"
+ ^true].
+ ^false].
+
+ clickState = #firstClickUp ifTrue:[
+ (timedOut) ifTrue:[
+ "timed out after mouseUp - signal timeout and pass the event"
+ aHand resetClickState.
+ self doubleClickTimeout. "***"
+ ^true].
+ localEvt isMouseDown ifTrue:["double click"
+ clickState := #secondClickDown.
+ ^false]].
+
+ clickState == #secondClickDown ifTrue: [
+ timedOut ifTrue:[
+ "timed out after second mouseDown - pass event after signaling timeout"
+ aHand resetClickState.
+ self doubleClickTimeout. "***"
+ ^true].
+ isDrag ifTrue: ["drag start"
+ self doubleClickTimeout. "***"
+ aHand resetClickState.
+ dragSelector "If no drag selector send #click instead"
+ ifNil: [self click]
+ ifNotNil: [self drag: firstClickDown].
+ ^true].
+ localEvt isMouseUp ifTrue: ["double click"
+ aHand resetClickState.
+ self doubleClick.
+ ^false]
+ ].
+
+ ^true
+ !
Item was added:
+ ----- Method: MouseClickState>>printOn: (in category 'as yet unclassified') -----
+ printOn: aStream
+ super printOn: aStream.
+ aStream nextPut: $[; print: clickState; nextPut: $]
+ !
Item was added:
+ UserInputEvent subclass: #MouseEvent
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: MouseEvent class>>anyButton (in category 'constants') -----
+ anyButton
+ ^ 7!
Item was added:
+ ----- Method: MouseEvent class>>blueButton (in category 'constants') -----
+ blueButton
+ ^ 1!
Item was added:
+ ----- Method: MouseEvent class>>redButton (in category 'constants') -----
+ redButton
+ ^ 4!
Item was added:
+ ----- Method: MouseEvent class>>yellowButton (in category 'constants') -----
+ yellowButton
+ ^ 2!
Item was added:
+ ----- Method: MouseEvent>>= (in category 'comparing') -----
+ = aMorphicEvent
+ super = aMorphicEvent ifFalse:[^false].
+ position = aMorphicEvent position ifFalse: [^ false].
+ buttons = aMorphicEvent buttons ifFalse: [^ false].
+ ^ true
+ !
Item was added:
+ ----- Method: MouseEvent>>anyButtonPressed (in category 'button state') -----
+ anyButtonPressed
+ "Answer true if any mouse button is being pressed."
+
+ ^ buttons anyMask: self class anyButton!
Item was added:
+ ----- Method: MouseEvent>>asMouseEnter (in category 'converting') -----
+ asMouseEnter
+ ^self clone setType: #mouseEnter!
Item was added:
+ ----- Method: MouseEvent>>asMouseLeave (in category 'converting') -----
+ asMouseLeave
+ ^self clone setType: #mouseLeave!
Item was added:
+ ----- Method: MouseEvent>>asMouseMove (in category 'converting') -----
+ asMouseMove
+ "Convert the receiver into a mouse move"
+ ^MouseMoveEvent new setType: #mouseMove startPoint: position endPoint: position trail: {position. position} buttons: buttons hand: source stamp: Time millisecondClockValue.!
Item was added:
+ ----- Method: MouseEvent>>asMouseOver (in category 'converting') -----
+ asMouseOver
+ "Convert the receiver into a mouse over event"
+ ^MouseEvent new setType: #mouseOver position: position buttons: buttons hand: source!
Item was added:
+ ----- Method: MouseEvent>>blueButtonPressed (in category 'button state') -----
+ blueButtonPressed
+ "Answer true if the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac."
+
+ ^ buttons anyMask: self class blueButton!
Item was added:
+ ----- Method: MouseEvent>>cursorPoint (in category 'accessing') -----
+ cursorPoint
+ "Answer the location of the cursor's hotspot when this event occured."
+
+ ^ position!
Item was added:
+ ----- Method: MouseEvent>>hash (in category 'comparing') -----
+ hash
+ ^ position hash + buttons hash!
Item was added:
+ ----- Method: MouseEvent>>isDraggingEvent (in category 'testing') -----
+ isDraggingEvent
+ source ifNil:[^false].
+ source hasSubmorphs ifTrue:[^true].
+ self anyButtonPressed ifTrue:[^true].
+ ^false!
Item was added:
+ ----- Method: MouseEvent>>isMouse (in category 'testing') -----
+ isMouse
+ ^true!
Item was added:
+ ----- Method: MouseEvent>>isMouseDown (in category 'testing') -----
+ isMouseDown
+ ^self type == #mouseDown!
Item was added:
+ ----- Method: MouseEvent>>isMouseEnter (in category 'testing') -----
+ isMouseEnter
+ ^self type == #mouseEnter!
Item was added:
+ ----- Method: MouseEvent>>isMouseLeave (in category 'testing') -----
+ isMouseLeave
+ ^self type == #mouseLeave!
Item was added:
+ ----- Method: MouseEvent>>isMouseMove (in category 'testing') -----
+ isMouseMove
+ ^self type == #mouseMove!
Item was added:
+ ----- Method: MouseEvent>>isMouseUp (in category 'testing') -----
+ isMouseUp
+ ^self type == #mouseUp!
Item was added:
+ ----- Method: MouseEvent>>isMove (in category 'testing') -----
+ isMove
+ ^false!
Item was added:
+ ----- Method: MouseEvent>>printOn: (in category 'printing') -----
+ printOn: aStream
+
+ aStream nextPut: $[.
+ aStream nextPutAll: self cursorPoint printString; space.
+ aStream nextPutAll: type; space.
+ aStream nextPutAll: self modifierString.
+ aStream nextPutAll: self buttonString.
+ aStream nextPutAll: timeStamp printString.
+ aStream nextPut: $].!
Item was added:
+ ----- Method: MouseEvent>>redButtonPressed (in category 'button state') -----
+ redButtonPressed
+ "Answer true if the red mouse button is being pressed. This is the first mouse button."
+
+ ^ buttons anyMask: self class redButton!
Item was added:
+ ----- Method: MouseEvent>>sentTo: (in category 'dispatching') -----
+ sentTo: anObject
+ "Dispatch the receiver into anObject"
+ type == #mouseOver ifTrue:[^anObject handleMouseOver: self].
+ type == #mouseEnter ifTrue:[^anObject handleMouseEnter: self].
+ type == #mouseLeave ifTrue:[^anObject handleMouseLeave: self].
+ ^super sentTo: anObject.!
Item was added:
+ ----- Method: MouseEvent>>setType: (in category 'private') -----
+ setType: aSymbol
+ "For quick conversion between event types"
+ type := aSymbol.!
Item was added:
+ ----- Method: MouseEvent>>setType:position:buttons:hand: (in category 'private') -----
+ setType: evtType position: evtPos buttons: evtButtons hand: evtHand
+ type := evtType.
+ position := evtPos.
+ buttons := evtButtons.
+ source := evtHand.
+ wasHandled := false.!
Item was added:
+ ----- Method: MouseEvent>>storeOn: (in category 'printing') -----
+ storeOn: aStream
+
+ aStream nextPutAll: type.
+ aStream space.
+ self timeStamp storeOn: aStream.
+ aStream space.
+ position x storeOn: aStream.
+ aStream space.
+ position y storeOn: aStream.
+ aStream space.
+ buttons storeOn: aStream.!
Item was added:
+ ----- Method: MouseEvent>>targetPoint (in category 'button state') -----
+ targetPoint
+ "Answer the location of the cursor's hotspot, adjusted by the offset
+ of the last mouseDown relative to the recipient morph."
+
+ ^ position - source targetOffset!
Item was added:
+ ----- Method: MouseEvent>>type:readFrom: (in category 'initialize') -----
+ type: eventType readFrom: aStream
+ | x y |
+ type := eventType.
+ timeStamp := Integer readFrom: aStream.
+ aStream skip: 1.
+ x := Integer readFrom: aStream.
+ aStream skip: 1.
+ y := Integer readFrom: aStream.
+ aStream skip: 1.
+ buttons := Integer readFrom: aStream.
+ position := x at y.
+ !
Item was added:
+ ----- Method: MouseEvent>>yellowButtonPressed (in category 'button state') -----
+ yellowButtonPressed
+ "Answer true if the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac."
+
+ ^ buttons anyMask: self class yellowButton!
Item was added:
+ MouseEvent subclass: #MouseMoveEvent
+ instanceVariableNames: 'startPoint trail'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: MouseMoveEvent>>= (in category 'comparing') -----
+ = aMorphicEvent
+ super = aMorphicEvent ifFalse:[^false].
+ position = aMorphicEvent position ifFalse: [^ false].
+ startPoint = aMorphicEvent startPoint ifFalse: [^ false].
+ buttons = aMorphicEvent buttons ifFalse: [^ false].
+ ^ true
+ !
Item was added:
+ ----- Method: MouseMoveEvent>>endPoint (in category 'accessing') -----
+ endPoint
+ "Return the point where the movement ended."
+ ^position!
Item was added:
+ ----- Method: MouseMoveEvent>>hash (in category 'comparing') -----
+ hash
+ ^ position hash + startPoint hash + buttons hash!
Item was added:
+ ----- Method: MouseMoveEvent>>isMove (in category 'testing') -----
+ isMove
+ ^true!
Item was added:
+ ----- Method: MouseMoveEvent>>printOn: (in category 'printing') -----
+ printOn: aStream
+
+ aStream nextPut: $[.
+ aStream nextPutAll: self startPoint printString; space.
+ aStream nextPutAll: self endPoint printString; space.
+ aStream nextPutAll: self type; space.
+ aStream nextPutAll: self modifierString.
+ aStream nextPutAll: self buttonString.
+ aStream nextPutAll: timeStamp printString.
+ aStream nextPut: $].!
Item was added:
+ ----- Method: MouseMoveEvent>>sentTo: (in category 'dispatching') -----
+ sentTo: anObject
+ "Dispatch the receiver into anObject"
+ type == #mouseMove ifTrue:[^anObject handleMouseMove: self].
+ ^super sentTo: anObject.
+ !
Item was added:
+ ----- Method: MouseMoveEvent>>setType:startPoint:endPoint:trail:buttons:hand:stamp: (in category 'private') -----
+ setType: evtType startPoint: evtStart endPoint: evtEnd trail: evtTrail buttons: evtButtons hand: evtHand stamp: stamp
+ type := evtType.
+ startPoint := evtStart.
+ position := evtEnd.
+ trail := evtTrail.
+ buttons := evtButtons.
+ source := evtHand.
+ wasHandled := false.
+ timeStamp := stamp.!
Item was added:
+ ----- Method: MouseMoveEvent>>startPoint (in category 'accessing') -----
+ startPoint
+ "Return the point where the movement started."
+ ^startPoint!
Item was added:
+ ----- Method: MouseMoveEvent>>storeOn: (in category 'printing') -----
+ storeOn: aStream
+ super storeOn: aStream.
+ aStream space.
+ self startPoint x storeOn: aStream.
+ aStream space.
+ self startPoint y storeOn: aStream.
+ aStream space.
+ "trail storeOn: aStream."!
Item was added:
+ ----- Method: MouseMoveEvent>>trail (in category 'accessing') -----
+ trail
+ "Return any immediate points that have been assembled along the move"
+ ^trail ifNil:[#()]!
Item was added:
+ ----- Method: MouseMoveEvent>>transformBy: (in category 'transforming') -----
+ transformBy: aMorphicTransform
+ "Transform the receiver into a local coordinate system."
+ position := aMorphicTransform globalPointToLocal: position.
+ startPoint := aMorphicTransform globalPointToLocal: startPoint.!
Item was added:
+ ----- Method: MouseMoveEvent>>translateBy: (in category 'transforming') -----
+ translateBy: delta
+ "add delta to cursorPoint, and return the new event"
+ position := position + delta.
+ startPoint := startPoint + delta.!
Item was added:
+ ----- Method: MouseMoveEvent>>type:readFrom: (in category 'initialize') -----
+ type: eventType readFrom: aStream
+ | x y |
+ super type: eventType readFrom: aStream.
+ aStream skip: 1.
+ x := Integer readFrom: aStream.
+ aStream skip: 1.
+ y := Integer readFrom: aStream.
+ startPoint := x at y.!
Item was added:
+ Object subclass: #MouseOverHandler
+ instanceVariableNames: 'mouseOverMorphs enteredMorphs overMorphs leftMorphs'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: MouseOverHandler>>initialize (in category 'initialize-release') -----
+ initialize
+
+ mouseOverMorphs := Array new.
+ self initializeTrackedMorphs!
Item was added:
+ ----- Method: MouseOverHandler>>initializeTrackedMorphs (in category 'initialize-release') -----
+ initializeTrackedMorphs
+
+ leftMorphs := OrderedCollection new.
+ overMorphs := WriteStream on: #().
+ enteredMorphs := WriteStream on: #().!
Item was added:
+ ----- Method: MouseOverHandler>>noticeMouseOver:event: (in category 'event handling') -----
+ noticeMouseOver: aMorph event: anEvent
+ "Remember that the mouse is currently over some morph"
+
+ leftMorphs remove: aMorph ifAbsent: [
+ enteredMorphs nextPut: aMorph ].
+ overMorphs nextPut: aMorph.
+ !
Item was added:
+ ----- Method: MouseOverHandler>>processMouseOver: (in category 'event handling') -----
+ processMouseOver: anEvent
+ "Re-establish the z-order for all morphs wrt the given event"
+
+ | hand localEvt focus evt |
+ hand := anEvent hand.
+ leftMorphs := mouseOverMorphs asIdentitySet.
+ "Assume some coherence for the number of objects in over list"
+ overMorphs := WriteStream on: (Array new: leftMorphs size).
+ enteredMorphs := WriteStream on: #().
+ "Now go looking for eventual mouse overs"
+ hand handleEvent: anEvent asMouseOver.
+ "Get out early if there's no change"
+ (leftMorphs isEmpty and: [ enteredMorphs position = 0 ])
+ ifTrue: [ ^self initializeTrackedMorphs ].
+ focus := hand mouseFocus.
+ "Send #mouseLeave as appropriate"
+ evt := anEvent asMouseLeave.
+ "Keep the order of the left morphs by recreating it from the mouseOverMorphs"
+ leftMorphs size > 1
+ ifTrue:
+ [leftMorphs := mouseOverMorphs select: [:m | leftMorphs includes: m]].
+ leftMorphs do: [ :m |
+ (m == focus or: [m hasOwner: focus])
+ ifFalse: [ overMorphs nextPut: m ]
+ ifTrue:
+ [ localEvt := evt transformedBy: (m transformedFrom: hand).
+ m handleEvent: localEvt ] ].
+ enteredMorphs ifNil: [ "inform: was called in handleEvent:"
+ ^self initializeTrackedMorphs ].
+ "Send #mouseEnter as appropriate"
+ evt := anEvent asMouseEnter.
+ enteredMorphs contents reverseDo: [ :m |
+ (m == focus or: [m hasOwner: focus]) ifTrue: [
+ localEvt := evt transformedBy: (m transformedFrom: hand).
+ m handleEvent: localEvt ] ].
+ "And remember the over list"
+ overMorphs ifNotNil: [ mouseOverMorphs := overMorphs contents ].
+ self initializeTrackedMorphs!
Item was added:
+ Morph subclass: #MovieMorph
+ instanceVariableNames: 'playMode msecsPerFrame rotationDegrees scalePoint frameList currentFrameIndex dwellCount'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
Item was added:
+ ----- Method: MovieMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+
+ | movies subMenu |
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu addLine.
+ subMenu := MenuMorph new defaultTarget: self.
+ frameList size > 1 ifTrue: [
+ subMenu add: 'repaint' translated action: #editDrawing.
+ subMenu add: 'set rotation center' translated action: #setRotationCenter.
+ subMenu add: 'play once' translated action: #playOnce.
+ subMenu add: 'play loop' translated action: #playLoop.
+ subMenu add: 'stop playing' translated action: #stopPlaying.
+ currentFrameIndex > 1 ifTrue: [
+ subMenu add: 'previous frame' translated action: #previousFrame].
+ currentFrameIndex < frameList size ifTrue: [
+ subMenu add: 'next frame' translated action: #nextFrame]].
+ subMenu add: 'extract this frame' translated action: #extractFrame:.
+ movies :=
+ (self world rootMorphsAt: aHandMorph targetPoint)
+ select: [:m | (m isKindOf: MovieMorph) or:
+ [m isSketchMorph]].
+ (movies size > 1) ifTrue:
+ [subMenu add: 'insert into movie' translated action: #insertIntoMovie:].
+ aCustomMenu add: 'movie...' translated subMenu: subMenu
+ !
Item was added:
+ ----- Method: MovieMorph>>advanceFrame (in category 'menu') -----
+ advanceFrame
+
+ currentFrameIndex < frameList size
+ ifTrue: [self setFrame: currentFrameIndex + 1]
+ ifFalse: [self setFrame: 1].
+ !
Item was added:
+ ----- Method: MovieMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: p
+ | frame |
+ frame := self currentFrame.
+ ^ (frame notNil and: [playMode = #stop])
+ ifTrue: [frame containsPoint: p]
+ ifFalse: [super containsPoint: p]!
Item was added:
+ ----- Method: MovieMorph>>currentFrame (in category 'private') -----
+ currentFrame
+ frameList isEmpty ifTrue: [^nil].
+ currentFrameIndex := currentFrameIndex min: (frameList size).
+ currentFrameIndex := currentFrameIndex max: 1.
+ ^frameList at: currentFrameIndex!
Item was added:
+ ----- Method: MovieMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color
+ r: 1
+ g: 0
+ b: 1!
Item was added:
+ ----- Method: MovieMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | frame |
+ frame := self currentFrame.
+ frame notNil
+ ifTrue: [^frame drawOn: aCanvas]
+ ifFalse: [^super drawOn: aCanvas]!
Item was added:
+ ----- Method: MovieMorph>>editDrawing (in category 'menu') -----
+ editDrawing
+ | frame |
+ frame := self currentFrame.
+ frame notNil
+ ifTrue: [frame editDrawingIn: self pasteUpMorph forBackground: false]!
Item was added:
+ ----- Method: MovieMorph>>extractFrame: (in category 'menu') -----
+ extractFrame: evt
+
+ | f |
+ f := self currentFrame.
+ f ifNil: [^ self].
+ frameList := frameList copyWithout: f.
+ frameList isEmpty
+ ifTrue: [self position: f position]
+ ifFalse: [self setFrame: currentFrameIndex].
+ evt hand attachMorph: f.
+ !
Item was added:
+ ----- Method: MovieMorph>>form (in category 'accessing') -----
+ form
+
+ ^ self currentFrame form
+ !
Item was added:
+ ----- Method: MovieMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ "#stop, #playOnce, or #loop"
+ playMode := #stop.
+ msecsPerFrame := 200.
+ rotationDegrees := 0.
+ scalePoint := 1.0 @ 1.0.
+ frameList := Array empty.
+ currentFrameIndex := 1.
+ dwellCount := 0!
Item was added:
+ ----- Method: MovieMorph>>insertFrames: (in category 'private') -----
+ insertFrames: newFrames
+ "Insert the given collection of frames into this movie just after the currentrame."
+
+ frameList isEmpty ifTrue: [
+ frameList := newFrames asArray copy.
+ self setFrame: 1.
+ ^ self].
+
+ frameList :=
+ frameList
+ copyReplaceFrom: currentFrameIndex + 1 "insert before"
+ to: currentFrameIndex
+ with: newFrames.
+ !
Item was added:
+ ----- Method: MovieMorph>>insertIntoMovie: (in category 'menu') -----
+ insertIntoMovie: evt
+
+ | movies aTarget |
+ movies :=
+ (self world rootMorphsAt: evt hand targetPoint)
+ select: [:m | ((m isKindOf: MovieMorph) or:
+ [m isSketchMorph]) and: [m ~= self]].
+ movies isEmpty ifTrue: [^ self].
+ aTarget := movies first.
+ (aTarget isSketchMorph) ifTrue:
+ [aTarget := aTarget replaceSelfWithMovie].
+ movies first insertFrames: frameList.
+ self delete.
+ !
Item was added:
+ ----- Method: MovieMorph>>nextFrame (in category 'menu') -----
+ nextFrame
+
+ currentFrameIndex < frameList size
+ ifTrue: [self setFrame: currentFrameIndex + 1].
+ !
Item was added:
+ ----- Method: MovieMorph>>playLoop (in category 'menu') -----
+ playLoop
+
+ playMode := #loop.
+ !
Item was added:
+ ----- Method: MovieMorph>>playOnce (in category 'menu') -----
+ playOnce
+
+ self setFrame: 1.
+ playMode := #playOnce.
+ !
Item was added:
+ ----- Method: MovieMorph>>previousFrame (in category 'menu') -----
+ previousFrame
+
+ currentFrameIndex > 1
+ ifTrue: [self setFrame: currentFrameIndex - 1].
+ !
Item was added:
+ ----- Method: MovieMorph>>rotationDegrees (in category 'rotate scale and flex') -----
+ rotationDegrees
+
+ ^ rotationDegrees
+ !
Item was added:
+ ----- Method: MovieMorph>>scalePoint (in category 'accessing') -----
+ scalePoint
+
+ ^ scalePoint
+ !
Item was added:
+ ----- Method: MovieMorph>>scalePoint: (in category 'accessing') -----
+ scalePoint: newScalePoint
+
+ | frame |
+ newScalePoint ~= scalePoint ifTrue: [
+ self changed.
+ scalePoint := newScalePoint.
+ frame := self currentFrame.
+ frame ifNotNil: [frame scalePoint: newScalePoint].
+ self layoutChanged.
+ self changed].
+ !
Item was added:
+ ----- Method: MovieMorph>>setFrame: (in category 'private') -----
+ setFrame: newFrameIndex
+ | oldFrame p newFrame |
+ oldFrame := self currentFrame.
+ oldFrame ifNil: [^self].
+ self changed.
+ p := oldFrame referencePosition.
+ currentFrameIndex := newFrameIndex.
+ currentFrameIndex := currentFrameIndex min: (frameList size).
+ currentFrameIndex := currentFrameIndex max: 1.
+ newFrame := frameList at: currentFrameIndex.
+ newFrame referencePosition: p.
+ oldFrame delete.
+ self addMorph: newFrame.
+ dwellCount := newFrame framesToDwell.
+ self layoutChanged.
+ self changed!
Item was added:
+ ----- Method: MovieMorph>>step (in category 'stepping and presenter') -----
+ step
+
+ playMode = #stop ifTrue: [^ self].
+
+ dwellCount > 0 ifTrue: [
+ dwellCount := dwellCount - 1.
+ ^ self].
+
+ currentFrameIndex < frameList size
+ ifTrue: [^ self setFrame: currentFrameIndex + 1].
+
+ playMode = #loop
+ ifTrue: [self setFrame: 1]
+ ifFalse: [playMode := #stop].
+ !
Item was added:
+ ----- Method: MovieMorph>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ msecsPerFrame
+ !
Item was added:
+ ----- Method: MovieMorph>>stopPlaying (in category 'menu') -----
+ stopPlaying
+
+ playMode := #stop.
+ self setFrame: 1.
+ !
Item was added:
+ PluggableCanvas subclass: #MultiCanvas
+ instanceVariableNames: 'canvases extent depth'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !MultiCanvas commentStamp: '<historical>' prior: 0!
+ A canvas which forwards drawing commands to sub-canvases.!
Item was added:
+ ----- Method: MultiCanvas>>addCanvas: (in category 'accessing') -----
+ addCanvas: aCanvas
+ canvases add: aCanvas!
Item was added:
+ ----- Method: MultiCanvas>>allocateForm: (in category 'initialization') -----
+ allocateForm: extentPoint
+ "Allocate a new form which is similar to the receiver and can be used for accelerated blts"
+ ^Form extent: extentPoint depth: self depth!
Item was added:
+ ----- Method: MultiCanvas>>apply: (in category 'private') -----
+ apply: aCommand
+
+ self flag: #roundedRudeness.
+ "This rudeness is to help get rounded corners to work right on RemoteCanvases. Since the RemoteCanvas has no other way to read its bits, we are grabbing them from Display for now. To support this, we need to see that the Display is written before any RemoteCanvases"
+
+ canvases do: [ :canvas |
+ (canvas isKindOf: FormCanvas) ifTrue: [aCommand value: canvas]
+ ].
+ canvases do: [ :canvas |
+ (canvas isKindOf: FormCanvas) ifFalse: [aCommand value: canvas]
+ ].
+ !
Item was added:
+ ----- Method: MultiCanvas>>clipRect (in category 'accessing') -----
+ clipRect
+
+ ^super clipRect ifNil: [
+ 0 at 0 extent: 5000 at 5000
+ ].!
Item was added:
+ ----- Method: MultiCanvas>>contentsOfArea:into: (in category 'accessing') -----
+ contentsOfArea: aRectangle into: aForm
+
+ self apply: [ :c |
+ (c isKindOf: FormCanvas) ifTrue: [
+ c contentsOfArea: aRectangle into: aForm.
+ ^aForm
+ ].
+ ].
+ self apply: [ :c |
+ c contentsOfArea: aRectangle into: aForm.
+ ^aForm.
+ ].
+ ^aForm!
Item was added:
+ ----- Method: MultiCanvas>>depth (in category 'accessing') -----
+ depth
+ ^depth!
Item was added:
+ ----- Method: MultiCanvas>>depth: (in category 'initialization') -----
+ depth: newDepth
+ "set the extent to be used with this canvas"
+ depth := newDepth.!
Item was added:
+ ----- Method: MultiCanvas>>extent (in category 'accessing') -----
+ extent
+ ^extent!
Item was added:
+ ----- Method: MultiCanvas>>extent: (in category 'initialization') -----
+ extent: newExtent
+ "set the extent to be used with this canvas"
+ extent := newExtent.!
Item was added:
+ ----- Method: MultiCanvas>>initialize (in category 'initialization') -----
+ initialize
+ canvases := Set new.
+ extent := 600 at 400.
+ depth := 32. !
Item was added:
+ ----- Method: MultiCanvas>>removeCanvas: (in category 'accessing') -----
+ removeCanvas: aCanvas
+ canvases remove: aCanvas ifAbsent: []!
Item was added:
+ PluggableButtonMorph subclass: #MultiWindowLabelButtonMorph
+ instanceVariableNames: 'savedMultiWindowState'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !MultiWindowLabelButtonMorph commentStamp: 'eem 6/30/2010 16:13' prior: 0!
+ A MultiWindowLabelButtonMorph is a means of implementing tabbed windows. It cooperates with PluggableSystemWindowWithButton to provide a drop-down menu of windows when clicking in the window label. It requires the model to create a suitable sub-instance of SavedMultiWindowState for inactive windows. To specify multi-windows use the multiWindowStyle: setter to customize a PluggableWindowSpec.
+
+ Instance Variables
+ savedMultiWindowState: <SavedMultiWindowState>
+
+ savedMultiWindowState
+ - the sequence of models in a multi-window.!
Item was added:
+ ----- Method: MultiWindowLabelButtonMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Be invisible."!
Item was added:
+ ----- Method: MultiWindowLabelButtonMorph>>performAction (in category 'accessing') -----
+ performAction
+ "Override to interpret the actionSelector as a menu accessor and to activate that menu."
+ actionSelector ifNotNil:
+ [(model perform: actionSelector) ifNotNil:
+ [:menu|
+ menu
+ invokeModalAt: self position - (0 at 5)
+ in: ActiveWorld
+ allowKeyboard: Preferences menuKeyboardControl]]!
Item was added:
+ ----- Method: MultiWindowLabelButtonMorph>>savedMultiWindowState (in category 'accessing') -----
+ savedMultiWindowState
+ "Answer the value of savedMultiWindowState"
+
+ ^ savedMultiWindowState!
Item was added:
+ ----- Method: MultiWindowLabelButtonMorph>>savedMultiWindowState: (in category 'accessing') -----
+ savedMultiWindowState: anObject
+ "Set the value of savedMultiWindowState"
+
+ savedMultiWindowState := anObject!
Item was added:
+ LazyListMorph subclass: #MulticolumnLazyListMorph
+ instanceVariableNames: 'columnWidths'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !MulticolumnLazyListMorph commentStamp: '<historical>' prior: 0!
+ A variant of LazyListMorph that can display multi-column lists.!
Item was added:
+ ----- Method: MulticolumnLazyListMorph>>display:atRow:on: (in category 'drawing') -----
+ display: items atRow: row on: canvas
+ "display the specified item, which is on the specified row; for Multicolumn
+ lists, items will be a list of strings"
+ | drawBounds |
+ drawBounds := (self drawBoundsForRow: row) translateBy: (self hMargin @ 0).
+ drawBounds := drawBounds intersect: self bounds.
+ items
+ with: (1 to: items size)
+ do: [:item :index |
+ "move the bounds to the right at each step"
+ index > 1
+ ifTrue: [drawBounds := drawBounds left: drawBounds left + 6
+ + (columnWidths at: index - 1)].
+ item isText
+ ifTrue: [canvas
+ drawString: item
+ in: drawBounds
+ font: (font
+ emphasized: (item emphasisAt: 1))
+ color: (self colorForRow: row)]
+ ifFalse: [canvas
+ drawString: item
+ in: drawBounds
+ font: font
+ color: (self colorForRow: row)]]!
Item was added:
+ ----- Method: MulticolumnLazyListMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ self getListSize = 0 ifTrue:[ ^self ].
+
+ self setColumnWidthsFor: aCanvas.
+
+ super drawOn: aCanvas!
Item was added:
+ ----- Method: MulticolumnLazyListMorph>>getListItem: (in category 'as yet unclassified') -----
+ getListItem: index
+ ^listSource getListRow: index!
Item was added:
+ ----- Method: MulticolumnLazyListMorph>>hUnadjustedScrollRange (in category 'scroll range') -----
+ hUnadjustedScrollRange
+ "multi column list morphs don't use hScrollbars"
+
+ ^0
+
+ !
Item was added:
+ ----- Method: MulticolumnLazyListMorph>>listChanged (in category 'as yet unclassified') -----
+ listChanged
+ columnWidths := nil.
+ super listChanged!
Item was added:
+ ----- Method: MulticolumnLazyListMorph>>setColumnWidthsFor: (in category 'drawing') -----
+ setColumnWidthsFor: aCanvas
+ | row topRow bottomRow |
+ "set columnWidths for drawing on the specified canvas"
+ columnWidths ifNil: [
+ columnWidths := (self item: 1) collect: [ :ignored | 0 ]. ].
+ topRow := (self topVisibleRowForCanvas: aCanvas) max: 1.
+ bottomRow := (self bottomVisibleRowForCanvas: aCanvas) max: 1.
+ topRow > bottomRow ifTrue: [ ^ self ].
+ topRow to: bottomRow do: [ :rowIndex |
+ row := self item: rowIndex.
+ columnWidths := columnWidths with: row collect: [ :currentWidth :item |
+ | widthOfItem |
+ widthOfItem := (font widthOfStringOrText: item).
+ widthOfItem > currentWidth
+ ifTrue: [ self changed. widthOfItem ]
+ ifFalse: [ currentWidth ] ] ]!
Item was added:
+ ----- Method: MulticolumnLazyListMorph>>widthToDisplayItem: (in category 'scroll range') -----
+ widthToDisplayItem: item
+ | widths |
+ widths := item collect: [ :each | super widthToDisplayItem: each ].
+ ^widths sum + (10 * (widths size - 1)) "add in space between the columns"
+ !
Item was added:
+ UpdatingStringMorph subclass: #NameStringInHalo
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !NameStringInHalo commentStamp: 'kfr 10/27/2003 16:29' prior: 0!
+ Shows the name of the morph in the halo. !
Item was added:
+ ----- Method: NameStringInHalo>>cancelEdits (in category 'editing') -----
+ cancelEdits
+ self interimContents: target externalName.
+ super cancelEdits!
Item was added:
+ ----- Method: NameStringInHalo>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ aCanvas fillRectangle: self bounds color: Color white.
+ super drawOn: aCanvas.!
Item was added:
+ ----- Method: NameStringInHalo>>interimContents: (in category 'accessing') -----
+ interimContents: aString
+ self contents: aString.
+ self placeContents!
Item was added:
+ ----- Method: NameStringInHalo>>placeContents (in category 'as yet unclassified') -----
+ placeContents
+ | namePosition |
+ (owner notNil and: [owner isInWorld]) ifTrue:
+ [namePosition := owner basicBox bottomCenter -
+ ((self width // 2) @ (owner handleSize negated // 2 - 1)).
+ namePosition := namePosition min: self world viewBox bottomRight - self extent y + 2.
+ self bounds: (namePosition extent: self extent)]!
Item was added:
+ Morph subclass: #NewBalloonMorph
+ instanceVariableNames: 'balloonOwner textMorph maximumWidth orientation hasTail'
+ classVariableNames: 'UseNewBalloonMorph'
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !NewBalloonMorph commentStamp: 'mt 3/31/2015 10:15' prior: 0!
+ A balloon is a bubble with an optional tail. It contains rich text, which describes something about its balloon-owner.!
Item was added:
+ ----- Method: NewBalloonMorph class>>string:for: (in category 'instance creation') -----
+ string: str for: morph
+
+ ^ self string: str for: morph corner: #bottomLeft!
Item was added:
+ ----- Method: NewBalloonMorph class>>string:for:corner: (in category 'instance creation') -----
+ string: message for: morph corner: symbol
+
+ ^ self new
+ balloonOwner: morph;
+ setText: message;
+ orientation: symbol;
+ yourself!
Item was added:
+ ----- Method: NewBalloonMorph class>>useNewBalloonMorph (in category 'preferences') -----
+ useNewBalloonMorph
+
+ <preference: 'Use new-style balloon morphs'
+ category: #Morphic
+ description: 'The new-style balloon morphs are improved for better reading quality and support rich text.'
+ type: #Boolean>
+ ^ UseNewBalloonMorph ifNil: [true]!
Item was added:
+ ----- Method: NewBalloonMorph class>>useNewBalloonMorph: (in category 'preferences') -----
+ useNewBalloonMorph: aBoolean
+
+ UseNewBalloonMorph := aBoolean.!
Item was added:
+ ----- Method: NewBalloonMorph>>balloonOwner (in category 'accessing') -----
+ balloonOwner
+
+ ^ balloonOwner!
Item was added:
+ ----- Method: NewBalloonMorph>>balloonOwner: (in category 'accessing') -----
+ balloonOwner: aMorph
+
+ balloonOwner := aMorph.!
Item was added:
+ ----- Method: NewBalloonMorph>>bubbleBounds (in category 'geometry') -----
+ bubbleBounds
+
+ ^ self bounds insetBy: (0 @ self tailHeight corner: 0 @ self tailHeight)!
Item was added:
+ ----- Method: NewBalloonMorph>>bubbleInset (in category 'geometry') -----
+ bubbleInset
+
+ ^ 5 at 2!
Item was added:
+ ----- Method: NewBalloonMorph>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+
+ ^ self defaultColor muchDarker"Color black"!
Item was added:
+ ----- Method: NewBalloonMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+
+ ^ 1!
Item was added:
+ ----- Method: NewBalloonMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+
+ ^ BalloonMorph balloonColor!
Item was added:
+ ----- Method: NewBalloonMorph>>drawDropShadowOn: (in category 'drawing') -----
+ drawDropShadowOn: aCanvas
+
+ aCanvas
+ translateBy: self shadowOffset
+ during: [ :shadowCanvas |
+ (shadowCanvas isVisible: self bubbleBounds) ifTrue: [
+ self wantsRoundedCorners
+ ifTrue: [shadowCanvas fillRoundRect: self bubbleBounds radius: self class preferredCornerRadius fillStyle: self shadowColor]
+ ifFalse: [shadowCanvas fillRectangle: self bubbleBounds fillStyle: self shadowColor]].
+
+ self hasTail ifTrue: [
+ shadowCanvas
+ drawPolygon: self verticesForTail
+ fillStyle: self shadowColor]].
+
+ !
Item was added:
+ ----- Method: NewBalloonMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ "Bubble."
+ self wantsRoundedCorners
+ ifTrue: [aCanvas
+ frameAndFillRoundRect: self bubbleBounds
+ radius: self class preferredCornerRadius fillStyle: self fillStyle borderWidth: self borderStyle width borderColor: self borderStyle color]
+ ifFalse: [aCanvas
+ fillRectangle: self bubbleBounds
+ fillStyle: self fillStyle borderStyle: self borderStyle].
+
+ "Tail."
+ self hasTail ifTrue: [
+ self verticesForTail in: [:points |
+ | pixelOffset |
+ pixelOffset := points first y < points second y
+ ifFalse: [points first x < points second x
+ ifTrue: [self borderStyle width negated @ self borderStyle width] "bottomLeft"
+ ifFalse: [self borderStyle width @ self borderStyle width]] "bottomRight"
+ ifTrue: [points first x < points second x
+ ifTrue: [self borderStyle width negated @ self borderStyle width negated] "topLeft"
+ ifFalse: [self borderStyle width @ self borderStyle width negated]]. "topRight"
+
+ aCanvas
+ drawPolygon: points
+ fillStyle: self fillStyle.
+ aCanvas
+ line: points first
+ to: points second + pixelOffset
+ width: self borderStyle width
+ color: self borderStyle color.
+ aCanvas
+ line: points first
+ to: points third + pixelOffset
+ width: self borderStyle width
+ color: self borderStyle color]]!
Item was added:
+ ----- Method: NewBalloonMorph>>hasTail (in category 'accessing') -----
+ hasTail
+
+ ^ hasTail ifNil: [true]!
Item was added:
+ ----- Method: NewBalloonMorph>>hasTail: (in category 'accessing') -----
+ hasTail: aBoolean
+
+ hasTail := aBoolean.!
Item was added:
+ ----- Method: NewBalloonMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+
+ self
+ borderWidth: self defaultBorderWidth;
+ borderColor: self defaultBorderColor;
+ color: (self defaultColor alpha: 1.0); "no alpha due to drop shadow"
+ hasDropShadow: true;
+ shadowOffset: 1 at 1;
+ shadowColor: (self color muchDarker muchDarker alpha: 0.333);
+ orientation: #bottomLeft.
+
+ MenuMorph roundedMenuCorners
+ ifTrue: [self cornerStyle: #rounded].
+
+ textMorph := TextMorph new
+ wrapFlag: false;
+ lock;
+ yourself.
+
+ self addMorph: textMorph.!
Item was added:
+ ----- Method: NewBalloonMorph>>maximumWidth (in category 'accessing') -----
+ maximumWidth
+
+ ^ maximumWidth ifNil: [
+ maximumWidth := (self balloonOwner balloonFont widthOf: $m) * Preferences maxBalloonHelpLineLength]!
Item was added:
+ ----- Method: NewBalloonMorph>>maximumWidth: (in category 'accessing') -----
+ maximumWidth: anInteger
+
+ maximumWidth := anInteger.!
Item was added:
+ ----- Method: NewBalloonMorph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+
+ "helpful for insuring some morphs always appear in front of or behind others.
+ smaller numbers are in front"
+
+ ^5 "Balloons are very front-like things"!
Item was added:
+ ----- Method: NewBalloonMorph>>move: (in category 'geometry') -----
+ move: targetPoint
+
+ self perform: (self orientation, #:) asSymbol with: targetPoint.!
Item was added:
+ ----- Method: NewBalloonMorph>>orientation (in category 'accessing') -----
+ orientation
+ "Encodes the position of the tail. #topLeft, #topRight, #bottomLeft, #bottomRight"
+
+ ^ orientation!
Item was added:
+ ----- Method: NewBalloonMorph>>orientation: (in category 'accessing') -----
+ orientation: aSymbol
+
+ orientation := aSymbol.
+ self changed.!
Item was added:
+ ----- Method: NewBalloonMorph>>popUpAt:forHand: (in category 'initialization') -----
+ popUpAt: point forHand: aHand
+ "Pop up the receiver as balloon help for the given hand"
+
+ #(bottomLeft topLeft bottomRight topRight) detect: [:nextOrientation |
+ | pointWithOffset |
+ self orientation: nextOrientation.
+ pointWithOffset := point + self tailOffset.
+ self move: pointWithOffset.
+ self bounds: (self bounds translatedToBeWithin: aHand world bounds).
+ (self bounds perform: self orientation) = pointWithOffset] ifNone: ["Keep last try."].
+
+ aHand world addMorphFront: self.
+ aHand balloonHelp: self.!
Item was added:
+ ----- Method: NewBalloonMorph>>popUpFor:hand: (in category 'initialization') -----
+ popUpFor: aMorph hand: aHand
+ "Pop up the receiver as balloon help for the given hand"
+
+ self balloonOwner: aMorph.
+ self popUpForHand: aHand.!
Item was added:
+ ----- Method: NewBalloonMorph>>popUpForHand: (in category 'initialization') -----
+ popUpForHand: aHand
+
+ self popUpAt: aHand position forHand: aHand.!
Item was added:
+ ----- Method: NewBalloonMorph>>setText: (in category 'initialization') -----
+ setText: stringOrText
+
+ | text |
+ text := stringOrText asText.
+ text addAttribute: (TextFontReference toFont: (self balloonOwner ifNil: [BalloonMorph]) balloonFont).
+
+ self textMorph wrapFlag: false.
+ self textMorph newContents: text.
+ self textMorph fullBounds.
+
+ (self maximumWidth > 0 and: [self textMorph width > self maximumWidth])
+ ifTrue: [
+ self textMorph
+ wrapFlag: true;
+ width: self maximumWidth].
+
+ self updateLayout.!
Item was added:
+ ----- Method: NewBalloonMorph>>tailHeight (in category 'geometry') -----
+ tailHeight
+
+ ^ 8!
Item was added:
+ ----- Method: NewBalloonMorph>>tailOffset (in category 'geometry') -----
+ tailOffset
+
+ ^ (Dictionary newFrom: {
+ #topLeft -> (5 at 0).
+ #topRight -> (-3 at 0).
+ #bottomLeft -> (1@ -1).
+ #bottomRight -> (-3 @ -3)}) at: self orientation!
Item was added:
+ ----- Method: NewBalloonMorph>>tailPosition (in category 'geometry') -----
+ tailPosition
+
+ ^ self innerBounds perform: self orientation!
Item was added:
+ ----- Method: NewBalloonMorph>>tailWidth (in category 'geometry') -----
+ tailWidth
+
+ ^ 15!
Item was added:
+ ----- Method: NewBalloonMorph>>textMorph (in category 'accessing - ui') -----
+ textMorph
+
+ ^ textMorph!
Item was added:
+ ----- Method: NewBalloonMorph>>updateLayout (in category 'layout') -----
+ updateLayout
+
+ self textMorph fullBounds.
+ self extent: self textMorph extent + (2* self bubbleInset) + (0 @ (2*self tailHeight)).
+ self textMorph center: self center.!
Item was added:
+ ----- Method: NewBalloonMorph>>verticesForTail (in category 'drawing') -----
+ verticesForTail
+
+ | offset factorX factorY tpos bpos |
+ offset := 5 + (self wantsRoundedCorners
+ ifTrue: [self class preferredCornerRadius]
+ ifFalse: [0]).
+ tpos := self tailPosition.
+ factorX := tpos x < self center x ifTrue: [1] ifFalse: [-1].
+ factorY := tpos y > self center y ifTrue: [1] ifFalse: [-1].
+ bpos := self bubbleBounds perform: self orientation.
+
+ ^ {
+ tpos.
+ bpos + (((offset + self tailWidth) * factorX) @ (self borderStyle width negated * factorY)).
+ bpos + ((offset * factorX) @ (self borderStyle width negated * factorY)).}!
Item was added:
+ Morph subclass: #NewColorPickerMorph
+ instanceVariableNames: 'target setColorSelector hsvaMorph colorPresenter'
+ classVariableNames: 'UseIt'
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !NewColorPickerMorph commentStamp: 'cmm 12/3/2010 13:36' prior: 0!
+ A NewColorPickerMorph is a new widget for choosing colors in Morphic. Instantiate a NewColorPickerMorph:
+
+ (NewColorPickerMorph
+ on: objectToHaveItsColorSet
+ getColorSelector: itsColorGetterSymbol
+ setColorSelector: itsColorSetterSymbol) openInWorld
+
+ !
Item was added:
+ ----- Method: NewColorPickerMorph class>>on: (in category 'create') -----
+ on: anObject
+ ^ self
+ on: anObject
+ originalColor: anObject color
+ setColorSelector: #color:!
Item was added:
+ ----- Method: NewColorPickerMorph class>>on:originalColor:setColorSelector: (in category 'create') -----
+ on: objectToHaveItsColorSet originalColor: originalColor setColorSelector: colorSetterSymbol
+ ^ self new
+ setTarget: objectToHaveItsColorSet
+ originalColor: originalColor
+ setColorSelector: colorSetterSymbol!
Item was added:
+ ----- Method: NewColorPickerMorph class>>useIt (in category 'accessing') -----
+ useIt
+ <preference: 'Use the new color-picker'
+ category: 'colors'
+ description: 'When true, a newly-enhanced color-picker is used.'
+ type: #Boolean>
+ ^ UseIt ifNil: [ false ]!
Item was added:
+ ----- Method: NewColorPickerMorph class>>useIt: (in category 'accessing') -----
+ useIt: aBoolean
+ UseIt := aBoolean!
Item was added:
+ ----- Method: NewColorPickerMorph>>closeButtonLabel (in category 'initialize-release') -----
+ closeButtonLabel
+ ^ 'Close' translated!
Item was added:
+ ----- Method: NewColorPickerMorph>>colorExpression (in category 'accessing') -----
+ colorExpression
+ "A Smalltalk which can create this color."
+ ^ self selectedColor printString!
Item was added:
+ ----- Method: NewColorPickerMorph>>colorExpression: (in category 'accessing') -----
+ colorExpression: aString
+ "Set my color by evaluating aString, a Smalltalk expression which results in a Color instance."
+ | col |
+ {aString.
+ 'Color ' , aString}
+ detect:
+ [ : each | ([ col := Compiler evaluate: each ]
+ on: Error
+ do:
+ [ : err | nil ]) notNil ]
+ ifNone: [ nil ].
+ col ifNotNil: [ self selectedColor: col ]!
Item was added:
+ ----- Method: NewColorPickerMorph>>colorSelected: (in category 'model') -----
+ colorSelected: aColor
+ self targetColor: aColor.
+ self changed: #colorExpression!
Item was added:
+ ----- Method: NewColorPickerMorph>>initialize (in category 'initialize-release') -----
+ initialize
+ super initialize.
+ self initializeHsvaMorph!
Item was added:
+ ----- Method: NewColorPickerMorph>>initializeHsvaMorph (in category 'initialize-release') -----
+ initializeHsvaMorph
+ hsvaMorph := HSVAColorSelectorMorph new
+ hResizing: #spaceFill ;
+ vResizing: #spaceFill ;
+ yourself.
+ hsvaMorph
+ when: #selectedColor
+ send: #colorSelected:
+ to: self!
Item was added:
+ ----- Method: NewColorPickerMorph>>newBottomRow (in category 'initialize-release') -----
+ newBottomRow
+ ^ Morph new
+ color: Color transparent ;
+ changeTableLayout ;
+ listDirection: #leftToRight ;
+ hResizing: #spaceFill; vResizing: #shrinkWrap ;
+ height: 20 ;
+ cellInset: 4 ;
+ addMorph: (StringMorph contents: 'Current selection:' translated) ;
+ addMorphBack: self newColorPresenterMorph ;
+ addMorphBack: self newCloseButton!
Item was added:
+ ----- Method: NewColorPickerMorph>>newCloseButton (in category 'initialize-release') -----
+ newCloseButton
+ ^ (PluggableButtonMorph
+ on: self
+ getState: nil
+ action: #delete
+ label: #closeButtonLabel)
+ vResizing: #spaceFill ;
+ yourself!
Item was added:
+ ----- Method: NewColorPickerMorph>>newColorExpressionMorph (in category 'initialize-release') -----
+ newColorExpressionMorph
+ | pluggable |
+ pluggable := (PluggableTextMorph
+ on: self
+ text: #colorExpression
+ accept: #colorExpression:)
+ hResizing: #spaceFill ;
+ vResizing: #rigid ;
+ height: 20 ;
+ acceptOnCR: true ;
+ retractableOrNot ;
+ yourself.
+ pluggable textMorph autoFit: false.
+ ^ pluggable!
Item was added:
+ ----- Method: NewColorPickerMorph>>newColorPresenterMorph (in category 'initialize-release') -----
+ newColorPresenterMorph
+ ^ (ColorPresenterMorph
+ on: hsvaMorph
+ color: #selectedColor)
+ vResizing: #rigid ; height: 20 ;
+ hResizing: #spaceFill ;
+ yourself!
Item was added:
+ ----- Method: NewColorPickerMorph>>selectedColor (in category 'accessing') -----
+ selectedColor
+ "The color selected."
+ ^ hsvaMorph selectedColor!
Item was added:
+ ----- Method: NewColorPickerMorph>>selectedColor: (in category 'accessing') -----
+ selectedColor: aColor
+ "The color selected."
+ hsvaMorph selectedColor: aColor!
Item was added:
+ ----- Method: NewColorPickerMorph>>setColorSelector (in category 'model') -----
+ setColorSelector
+ "Answer the value of setColorSelector"
+
+ ^ setColorSelector!
Item was added:
+ ----- Method: NewColorPickerMorph>>setTarget:originalColor:setColorSelector: (in category 'initialize-release') -----
+ setTarget: objectToHaveItsColorSet originalColor: aColor setColorSelector: colorSetterSymbol
+ target := objectToHaveItsColorSet.
+ setColorSelector := colorSetterSymbol.
+ hsvaMorph selectedColor: aColor.
+ self setup!
Item was added:
+ ----- Method: NewColorPickerMorph>>setup (in category 'initialize-release') -----
+ setup
+ self
+ color: (Color white slightlyDarker alpha: 0.88) ;
+ cornerStyle: #rounded ;
+ changeTableLayout ;
+ hResizing: #rigid ;
+ vResizing: #rigid ;
+ extent: 240 at 240 ;
+ addMorphBack: hsvaMorph ;
+ addMorphBack: self newColorExpressionMorph ;
+ addMorphBack: self newBottomRow ;
+ layoutInset: 4 ;
+ cellInset: 0!
Item was added:
+ ----- Method: NewColorPickerMorph>>target (in category 'model') -----
+ target
+ "Answer the object whose color will be controlled."
+ ^ target!
Item was added:
+ ----- Method: NewColorPickerMorph>>targetColor: (in category 'accessing') -----
+ targetColor: aColor
+ "The color of my target."
+ target ifNotNil:
+ [ target
+ perform: setColorSelector
+ with: aColor ]!
Item was added:
+ HandleMorph subclass: #NewHandleMorph
+ instanceVariableNames: 'hand offset waitingForClickInside'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: NewHandleMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ ^ false!
Item was added:
+ ----- Method: NewHandleMorph>>delete (in category 'submorphs-add/remove') -----
+ delete
+ hand ifNotNil:[
+ hand showTemporaryCursor: nil.
+ ].
+ super delete.!
Item was added:
+ ----- Method: NewHandleMorph>>followHand:forEachPointDo:lastPointDo: (in category 'all') -----
+ followHand: aHand forEachPointDo: block1 lastPointDo: block2
+ hand := aHand.
+ pointBlock := block1.
+ lastPointBlock := block2.
+ self position: hand lastEvent cursorPoint - (self extent // 2)!
Item was added:
+ ----- Method: NewHandleMorph>>followHand:forEachPointDo:lastPointDo:withCursor: (in category 'all') -----
+ followHand: aHand forEachPointDo: block1 lastPointDo: block2 withCursor: aCursor
+ hand := aHand.
+ hand showTemporaryCursor: aCursor "hotSpotOffset: aCursor offset negated".
+ borderWidth := 0.
+ color := Color transparent.
+ pointBlock := block1.
+ lastPointBlock := block2.
+ self position: hand lastEvent cursorPoint - (self extent // 2)!
Item was added:
+ ----- Method: NewHandleMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+
+ super initialize.
+ ""
+ waitingForClickInside := true.
+ Preferences noviceMode
+ ifTrue: [self setBalloonText: 'stretch']!
Item was added:
+ ----- Method: NewHandleMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: aMorph event: anEvent
+ "No dropping behavior because stepping will delete me.
+ Moreover it needs to be done that way to evaluate lastPointBlock"
+ !
Item was added:
+ ----- Method: NewHandleMorph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+
+ ^1 "handles are very front-like - e.g. the spawn reframe logic actually asks if the first submorph of the world is one of us before deciding to create one"!
Item was added:
+ ----- Method: NewHandleMorph>>sensorMode (in category 'all') -----
+ sensorMode
+
+ "If our client is still addressing the Sensor directly, we need to do so as well"
+ ^self valueOfProperty: #sensorMode ifAbsent: [false].
+ !
Item was added:
+ ----- Method: NewHandleMorph>>sensorMode: (in category 'all') -----
+ sensorMode: aBoolean
+
+ "If our client is still addressing the Sensor directly, we need to do so as well"
+ self setProperty: #sensorMode toValue: aBoolean.
+ !
Item was added:
+ ----- Method: NewHandleMorph>>step (in category 'stepping and presenter') -----
+ step
+ | eventSource |
+
+ eventSource := self sensorMode ifTrue: [
+ Sensor
+ ] ifFalse: [
+ hand lastEvent
+ ].
+ eventSource anyButtonPressed
+ ifTrue: [waitingForClickInside := false.
+ self position: eventSource cursorPoint - (self extent // 2).
+ pointBlock value: self center]
+ ifFalse: [waitingForClickInside
+ ifTrue: [(self containsPoint: eventSource cursorPoint)
+ ifFalse: ["mouse wandered out before clicked"
+ ^ self delete]]
+ ifFalse: [lastPointBlock value: self center.
+ ^ self delete]]!
Item was added:
+ ----- Method: NewHandleMorph>>undoGrabCommand (in category 'dropping/grabbing') -----
+ undoGrabCommand
+ ^nil!
Item was added:
+ Object subclass: #NewParagraph
+ instanceVariableNames: 'text textStyle firstCharacterIndex container lines positionWhenComposed offsetToEnd maxRightX selectionStart selectionStop wantsColumnBreaks focused caretRect showCaret'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !NewParagraph commentStamp: '<historical>' prior: 0!
+ A Paragraph represents text that has been laid out, or composed, in some container.
+ text A Text with encoded per-character emphasis.
+ textStyle A TextStyle with font set, line height and horizontal alignment.
+ firstCharacterIndex The starting index in text for this paragraph, allowing
+ composition of a long text into a number of containers.
+ container A Rectangle or TextContainer that determines where text can go.
+ lines An Array of TextLines comprising the final layout of the text
+ after it has been composed within its container.
+ positionWhenComposed As its name implies. Allows display at new locations
+ without the need to recompose the text.
+ Lines are ordered vertically. However, for a given y, there may be several lines in left to right order. Lines must never be empty, even if text is empty.
+
+ Notes on yet another hack - 5 Feb 2001
+
+ We really need to clean up #composeLinesFrom:to:delta:into:priorLines:atY:!!!!!!
+
+ I added one more habdful of code to correct:
+
+ This is an annoying bug that's been around for a couple of years, but I finally figured out how to duplicate the problem, so I figured I'd just report it now. (It doesn't necessarily have to be fixed for 3.0 if it looks messy, but if it's a simple fix, it would be worth it.)
+
+ In Morphic, if you have the following text in a workspace:
+
+ This is line 1
+ This is line 2
+
+ **and** you have a return character after line 2, you will normally be able to click the mouse two times below line 2 in order to select all the text. If you edit line 2 (e.g. so that it reads "line number 2"), you can still select all the text by clicking below the second line. However, if you edit line 1, you will not be able to select all the text from the bottom in the same way. Things get messed up such that the last return character seems to be gone. In this state, if you position the cursor immediately after the 2, and press the right arrow, the cursor jumps to the beginning of line 2... oof. (report by Doug Way)
+
+ While I don't have a very deep understanding of the above mentioned method, I was able to determine that text ending in a CR worked better in the editor when the last entry in <lines> had a start of text size + 1 and a stop of text size. I have accordingly added code near the end to ensure this. It seems to have fixed the problem, but we do need to clean this baby up some day. - Bob
+ !
Item was added:
+ ----- Method: NewParagraph>>adjustLineIndicesBy: (in category 'private') -----
+ adjustLineIndicesBy: delta
+ firstCharacterIndex := firstCharacterIndex + delta.
+ lines do: [:line | line slide: delta].
+ !
Item was added:
+ ----- Method: NewParagraph>>adjustRightX (in category 'private') -----
+ adjustRightX
+ | shrink |
+ shrink := container right - maxRightX.
+ lines do: [:line | line paddingWidth: (line paddingWidth - shrink)].
+ container := container withRight: maxRightX!
Item was added:
+ ----- Method: NewParagraph>>adjustedFirstCharacterIndex (in category 'access') -----
+ adjustedFirstCharacterIndex
+ "Return the index in the text where this paragraph WOULD begin if nothing had changed, except the size of the text -- ie if there have only been an insertion of deletion in the preceding morphs"
+ offsetToEnd ifNil: [^ -1].
+ ^ text size - offsetToEnd!
Item was added:
+ ----- Method: NewParagraph>>asParagraphForPostscript (in category 'display') -----
+ asParagraphForPostscript
+
+ ^ self!
Item was added:
+ ----- Method: NewParagraph>>attributesAt: (in category 'editing') -----
+ attributesAt: aPoint
+ "Answer the attributes at the given point"
+ ^text attributesAt: (self characterBlockAtPoint: aPoint) stringIndex forStyle: textStyle!
Item was added:
+ ----- Method: NewParagraph>>caretRect (in category 'access') -----
+ caretRect
+ "The rectangle in which the caret was last drawn,
+ or nil if the last drawing drew a range-selection rather than insertion point."
+ ^ caretRect!
Item was added:
+ ----- Method: NewParagraph>>caretWidth (in category 'access') -----
+ caretWidth
+ ^ Editor dumbbellCursor
+ ifTrue: [ 2 ]
+ ifFalse: [ 0 ]!
Item was added:
+ ----- Method: NewParagraph>>centered (in category 'alignment') -----
+ centered
+ textStyle centered!
Item was added:
+ ----- Method: NewParagraph>>characterBlockAtPoint: (in category 'selection') -----
+ characterBlockAtPoint: aPoint
+ "Answer a CharacterBlock for the character in the text at aPoint."
+ | line |
+ line := lines at: (self lineIndexForPoint: aPoint).
+ ^(CharacterBlockScanner new text: text textStyle: textStyle)
+ characterBlockAtPoint: aPoint index: nil
+ in: line!
Item was added:
+ ----- Method: NewParagraph>>characterBlockForIndex: (in category 'selection') -----
+ characterBlockForIndex: index
+ "Answer a CharacterBlock for the character in text at index."
+ | line |
+ line := lines at: (self lineIndexOfCharacterIndex: index).
+ ^ (CharacterBlockScanner new text: text textStyle: textStyle)
+ characterBlockAtPoint: nil index: ((index max: line first) min: text size+1)
+ in: line!
Item was added:
+ ----- Method: NewParagraph>>clickAt:for:controller: (in category 'editing') -----
+ clickAt: clickPoint for: model controller: editor
+ "Give sensitive text a chance to fire. Display flash: (100 at 100 extent: 100 at 100)."
+ | startBlock action |
+ action := false.
+ startBlock := self characterBlockAtPoint: clickPoint.
+ (text attributesAt: startBlock stringIndex forStyle: textStyle)
+ do: [:att | | range target box boxes |
+ att mayActOnClick ifTrue:
+ [(target := model) ifNil: [target := editor morph].
+ range := text rangeOf: att startingAt: startBlock stringIndex.
+ boxes := self selectionRectsFrom: (self characterBlockForIndex: range first)
+ to: (self characterBlockForIndex: range last+1).
+ box := boxes detect: [:each | each containsPoint: clickPoint] ifNone: [nil].
+ box ifNotNil:
+ [ box := (editor transformFrom: nil) invertBoundsRect: box.
+ editor morph allOwnersDo: [ :m | box := box intersect: (m boundsInWorld) ].
+ Utilities awaitMouseUpIn: box
+ repeating: []
+ ifSucceed: [(att actOnClickFor: target in: self at: clickPoint editor: editor) ifTrue: [action := true]].
+ Cursor currentCursor == Cursor webLink ifTrue:[Cursor normal show].
+ ]]].
+ ^ action!
Item was added:
+ ----- Method: NewParagraph>>compose:style:from:in: (in category 'composition') -----
+ compose: t style: ts from: startingIndex in: textContainer
+ text := t.
+ textStyle := ts.
+ firstCharacterIndex := startingIndex.
+ offsetToEnd := text size - firstCharacterIndex.
+ container := textContainer.
+ self composeAll!
Item was added:
+ ----- Method: NewParagraph>>composeAll (in category 'composition') -----
+ composeAll
+ self composeLinesFrom: firstCharacterIndex to: text size delta: 0
+ into: OrderedCollection new priorLines: Array new atY: container top!
Item was added:
+ ----- Method: NewParagraph>>composeAllStartingAt: (in category 'composition') -----
+ composeAllStartingAt: characterIndex
+ firstCharacterIndex := characterIndex.
+ offsetToEnd := text size - firstCharacterIndex.
+ self composeAll!
Item was added:
+ ----- Method: NewParagraph>>composeLinesFrom:to:delta:into:priorLines:atY: (in category 'composition') -----
+ composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines
+ atY: startingY
+ "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values"
+
+ | newResult |
+
+ newResult := TextComposer new
+ composeLinesFrom: start
+ to: stop
+ delta: delta
+ into: lineColl
+ priorLines: priorLines
+ atY: startingY
+ textStyle: textStyle
+ text: text
+ container: container
+ wantsColumnBreaks: wantsColumnBreaks == true.
+ lines := newResult first asArray.
+ maxRightX := newResult second.
+ ^maxRightX
+ !
Item was added:
+ ----- Method: NewParagraph>>compositionRectangle (in category 'composition') -----
+ compositionRectangle
+ ^ container!
Item was added:
+ ----- Method: NewParagraph>>containsPoint: (in category 'selection') -----
+ containsPoint: aPoint
+ ^ (lines at: (self lineIndexForPoint: aPoint)) rectangle
+ containsPoint: aPoint!
Item was added:
+ ----- Method: NewParagraph>>deepCopy (in category 'copying') -----
+ deepCopy
+ "Don't want to copy the container (etc) or fonts in the TextStyle."
+ | new |
+ new := self copy.
+ new textStyle: textStyle copy
+ lines: lines copy
+ text: text deepCopy.
+ ^ new!
Item was added:
+ ----- Method: NewParagraph>>defaultCharacterBlock (in category 'selection') -----
+ defaultCharacterBlock
+ ^ (CharacterBlock new stringIndex: firstCharacterIndex text: text
+ topLeft: lines first topLeft extent: 0 @ 0)
+ textLine: lines first!
Item was added:
+ ----- Method: NewParagraph>>displayOn:using:at: (in category 'fonts-display') -----
+ displayOn: aCanvas using: displayScanner at: somePosition
+ "Send all visible lines to the displayScanner for display"
+ | visibleRectangle offset leftInRun line |
+ visibleRectangle := aCanvas clipRect.
+ offset := (somePosition - positionWhenComposed) truncated.
+ leftInRun := 0.
+ (self lineIndexForPoint: visibleRectangle topLeft)
+ to: (self lineIndexForPoint: visibleRectangle bottomRight)
+ do: [:i | line := lines at: i.
+ self displaySelectionInLine: line on: aCanvas.
+ line first <= line last ifTrue:
+ [leftInRun := displayScanner displayLine: line
+ offset: offset leftInRun: leftInRun]].
+ !
Item was added:
+ ----- Method: NewParagraph>>displaySelectionInLine:on: (in category 'display') -----
+ displaySelectionInLine: line on: aCanvas
+ | leftX rightX w caretColor |
+ selectionStart ifNil: [^self]. "No selection"
+ aCanvas isShadowDrawing ifTrue: [ ^self ]. "don't draw selection with shadow"
+ selectionStart = selectionStop
+ ifTrue:
+ ["Only show caret on line where clicked"
+
+ selectionStart textLine ~= line ifTrue: [^self]]
+ ifFalse:
+ ["Test entire selection before or after here"
+
+ (selectionStop stringIndex < line first
+ or: [selectionStart stringIndex > (line last + 1)]) ifTrue: [^self]. "No selection on this line"
+ (selectionStop stringIndex = line first
+ and: [selectionStop textLine ~= line]) ifTrue: [^self]. "Selection ends on line above"
+ (selectionStart stringIndex = (line last + 1)
+ and: [selectionStop textLine ~= line]) ifTrue: [^self]]. "Selection begins on line below"
+ leftX := (selectionStart stringIndex < line first
+ ifTrue: [line ]
+ ifFalse: [selectionStart ])left.
+ rightX := (selectionStop stringIndex > (line last + 1) or:
+ [selectionStop stringIndex = (line last + 1)
+ and: [selectionStop textLine ~= line]])
+ ifTrue: [line right]
+ ifFalse: [selectionStop left].
+ selectionStart = selectionStop
+ ifTrue:
+ [rightX := rightX + 1.
+ w := self caretWidth.
+ caretRect := (leftX-w) @ line top corner: (rightX+w)@ line bottom.
+ self showCaret ifFalse:[^self].
+ caretColor := self insertionPointColor.
+ 1 to: w
+ do:
+ [:i |
+ "Draw caret triangles at top and bottom"
+
+ aCanvas fillRectangle: ((leftX - w + i - 1) @ (line top + i - 1)
+ extent: ((w - i) * 2 + 3) @ 1)
+ color: caretColor.
+ aCanvas fillRectangle: ((leftX - w + i - 1) @ (line bottom - i)
+ extent: ((w - i) * 2 + 3) @ 1)
+ color: caretColor].
+ aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom)
+ color: caretColor]
+ ifFalse:
+ [caretRect := nil.
+ aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom)
+ color: self selectionColor]!
Item was added:
+ ----- Method: NewParagraph>>extent (in category 'access') -----
+ extent
+ ^ container width @ (lines last bottom - lines first top)!
Item was added:
+ ----- Method: NewParagraph>>fastFindFirstLineSuchThat: (in category 'private') -----
+ fastFindFirstLineSuchThat: lineBlock
+ "Perform a binary search of the lines array and return the index
+ of the first element for which lineBlock evaluates as true.
+ This assumes the condition is one that goes from false to true for
+ increasing line numbers (as, eg, yval > somey or start char > somex).
+ If lineBlock is not true for any element, return size+1."
+
+ ^lines
+ findBinaryIndex: [ :each |
+ (lineBlock value: each)
+ ifTrue: [ -1 ]
+ ifFalse: [ 1 ] ]
+ ifNone: [ :lower :upper | upper ]!
Item was added:
+ ----- Method: NewParagraph>>firstCharacterIndex (in category 'access') -----
+ firstCharacterIndex
+ ^ firstCharacterIndex!
Item was added:
+ ----- Method: NewParagraph>>fixLastWithHeight: (in category 'composition') -----
+ fixLastWithHeight: lineHeightGuess
+ "This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I coul;dn't figure out where to put it in the main logic."
+
+ | oldLastLine newRectangle line |
+
+ (text size > 1 and: [text last = Character cr]) ifFalse: [^self].
+
+ oldLastLine := lines last.
+ oldLastLine last - oldLastLine first >= 0 ifFalse: [^self].
+ oldLastLine last = text size ifFalse: [^self].
+
+ newRectangle := oldLastLine left @ oldLastLine bottom
+ extent: 0@(oldLastLine bottom - oldLastLine top).
+ "Even though we may be below the bottom of the container,
+ it is still necessary to compose the last line for consistency..."
+
+ line := TextLine start: text size+1 stop: text size internalSpaces: 0 paddingWidth: 0.
+ line rectangle: newRectangle.
+ line lineHeight: lineHeightGuess baseline: textStyle baseline.
+ lines := lines, (Array with: line).
+ !
Item was added:
+ ----- Method: NewParagraph>>focused (in category 'access') -----
+ focused
+ focused ifNil: [focused := false].
+ ^ focused!
Item was added:
+ ----- Method: NewParagraph>>focused: (in category 'access') -----
+ focused: aBoolean
+ focused := aBoolean!
Item was added:
+ ----- Method: NewParagraph>>indentationOfLineIndex:ifBlank: (in category 'private') -----
+ indentationOfLineIndex: lineIndex ifBlank: aBlock
+ "Answer the number of leading tabs in the line at lineIndex. If there are
+ no visible characters, pass the number of tabs to aBlock and return its value.
+ If the line is word-wrap overflow, back up a line and recur."
+
+ | arrayIndex first last crlf |
+ crlf := CharacterSet crlf.
+ arrayIndex := lineIndex.
+ [first := (lines at: arrayIndex) first.
+ first > 1 and: [crlf includes: (text string at: first - 1)]] whileTrue: "word wrap"
+ [arrayIndex := arrayIndex - 1].
+ last := (lines at: arrayIndex) last.
+
+ ^(text string copyFrom: first to: last) indentationIfBlank: aBlock.
+ !
Item was added:
+ ----- Method: NewParagraph>>initialize (in category 'initialize-release') -----
+ initialize
+ self positionWhenComposed: 0 @ 0!
Item was added:
+ ----- Method: NewParagraph>>insertionPointColor (in category 'display') -----
+ insertionPointColor
+ self focused ifFalse: [^ Color transparent].
+ ^ Display depth <= 2
+ ifTrue: [Color black]
+ ifFalse: [Preferences insertionPointColor]!
Item was added:
+ ----- Method: NewParagraph>>justified (in category 'alignment') -----
+ justified
+ textStyle justified!
Item was added:
+ ----- Method: NewParagraph>>lastCharacterIndex (in category 'access') -----
+ lastCharacterIndex
+ ^ lines last last!
Item was added:
+ ----- Method: NewParagraph>>lastLine (in category 'private') -----
+ lastLine
+
+ ^lines last!
Item was added:
+ ----- Method: NewParagraph>>leftFlush (in category 'alignment') -----
+ leftFlush
+ textStyle leftFlush!
Item was added:
+ ----- Method: NewParagraph>>lineIndexForCharacter: (in category 'private') -----
+ lineIndexForCharacter: characterIndex
+ "Deprecated"
+
+ ^self lineIndexOfCharacterIndex: characterIndex !
Item was added:
+ ----- Method: NewParagraph>>lineIndexForPoint: (in category 'private') -----
+ lineIndexForPoint: aPoint
+ "Answer the index of the line in which to select the character nearest to aPoint."
+ | i py |
+ py := aPoint y truncated.
+
+ "Find the first line at this y-value"
+ i := (self fastFindFirstLineSuchThat: [:line | line bottom > py]) min: lines size.
+
+ "Now find the first line at this x-value"
+ [i < lines size and: [(lines at: i+1) top = (lines at: i) top
+ and: [aPoint x >= (lines at: i+1) left]]]
+ whileTrue: [i := i + 1].
+ ^ i!
Item was added:
+ ----- Method: NewParagraph>>lineIndexOfCharacterIndex: (in category 'private') -----
+ lineIndexOfCharacterIndex: index
+ "Answer the index of the line in which to select the character at index."
+ ^ (self fastFindFirstLineSuchThat: [:line | line first > index]) - 1 max: 1!
Item was added:
+ ----- Method: NewParagraph>>lines (in category 'private') -----
+ lines
+ ^ lines!
Item was added:
+ ----- Method: NewParagraph>>moveBy: (in category 'private') -----
+ moveBy: delta
+ lines do: [:line | line moveBy: delta].
+ positionWhenComposed ifNotNil:[
+ positionWhenComposed := positionWhenComposed + delta].
+ container := container translateBy: delta!
Item was added:
+ ----- Method: NewParagraph>>numberOfLines (in category 'access') -----
+ numberOfLines
+
+ ^lines size!
Item was added:
+ ----- Method: NewParagraph>>positionWhenComposed: (in category 'private') -----
+ positionWhenComposed: pos
+ positionWhenComposed := pos!
Item was added:
+ ----- Method: NewParagraph>>recomposeFrom:to:delta: (in category 'composition') -----
+ recomposeFrom: start to: stop delta: delta
+ "Recompose this paragraph. The altered portion is between start and stop.
+ Recomposition may continue to the end of the text, due to a ripple effect.
+ Delta is the amount by which the current text is longer than it was
+ when its current lines were composed."
+ | startLine newLines |
+ "Have to recompose line above in case a word-break was affected."
+ startLine := (self lineIndexOfCharacterIndex: start) - 1 max: 1.
+ [startLine > 1 and: [(lines at: startLine-1) top = (lines at: startLine) top]]
+ whileTrue: [startLine := startLine - 1]. "Find leftmost of line pieces"
+ newLines := OrderedCollection new: lines size + 1.
+ 1 to: startLine-1 do: [:i | newLines addLast: (lines at: i)].
+ self composeLinesFrom: (lines at: startLine) first to: stop delta: delta
+ into: newLines priorLines: lines
+ atY: (lines at: startLine) top!
Item was added:
+ ----- Method: NewParagraph>>replaceFrom:to:with: (in category 'editing') -----
+ replaceFrom: start to: stop with: aText
+ "Edit the text, and then recompose the lines."
+ text replaceFrom: start to: stop with: aText.
+ self recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop-start+1)!
Item was added:
+ ----- Method: NewParagraph>>replaceFrom:to:with:displaying: (in category 'editing') -----
+ replaceFrom: start to: stop with: aText displaying: displayBoolean
+ "Edit the text, and then recompose the lines."
+ text replaceFrom: start to: stop with: aText.
+ self recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop-start+1)!
Item was added:
+ ----- Method: NewParagraph>>rightFlush (in category 'alignment') -----
+ rightFlush
+ textStyle rightFlush!
Item was added:
+ ----- Method: NewParagraph>>selectionColor (in category 'display') -----
+ selectionColor
+ | color |
+ Display depth = 1 ifTrue: [^ Color veryLightGray].
+ Display depth = 2 ifTrue: [^ Color gray].
+ color := Preferences textHighlightColor.
+ self focused ifFalse: [color := color alphaMixed: 0.2 with: Color veryVeryLightGray].
+ ^ color!
Item was added:
+ ----- Method: NewParagraph>>selectionRects (in category 'selection') -----
+ selectionRects
+ "Return an array of rectangles representing the selection region."
+ selectionStart ifNil: [^ Array new].
+ ^ self selectionRectsFrom: selectionStart to: selectionStop!
Item was added:
+ ----- Method: NewParagraph>>selectionRectsFrom:to: (in category 'selection') -----
+ selectionRectsFrom: characterBlock1 to: characterBlock2
+ "Return an array of rectangles representing the area between the two character blocks given as arguments."
+ | line1 line2 rects cb1 cb2 w |
+ characterBlock1 <= characterBlock2
+ ifTrue: [cb1 := characterBlock1. cb2 := characterBlock2]
+ ifFalse: [cb2 := characterBlock1. cb1 := characterBlock2].
+ cb1 = cb2 ifTrue:
+ [w := self caretWidth.
+ ^ Array with: (cb1 topLeft - (w at 0) corner: cb1 bottomLeft + ((w+1)@0))].
+ line1 := self lineIndexOfCharacterIndex: cb1 stringIndex.
+ line2 := self lineIndexOfCharacterIndex: cb2 stringIndex.
+ line1 = line2 ifTrue:
+ [^ Array with: (cb1 topLeft corner: cb2 bottomRight)].
+ rects := OrderedCollection new.
+ rects addLast: (cb1 topLeft corner: (lines at: line1) bottomRight).
+ line1+1 to: line2-1 do: [ :i |
+ | line |
+ line := lines at: i.
+ (line left = rects last left and: [ line right = rects last right ])
+ ifTrue: [ "new line has same margins as old one -- merge them, so that the caller gets as few rectangles as possible"
+ | lastRect |
+ lastRect := rects removeLast.
+ rects add: (lastRect bottom: line bottom) ]
+ ifFalse: [ "differing margins; cannot merge"
+ rects add: line rectangle ] ].
+
+ rects addLast: ((lines at: line2) topLeft corner: cb2 bottomLeft).
+ ^ rects!
Item was added:
+ ----- Method: NewParagraph>>selectionStart:selectionStop: (in category 'selection') -----
+ selectionStart: startBlock selectionStop: stopBlock
+ selectionStart := startBlock.
+ selectionStop := stopBlock.!
Item was added:
+ ----- Method: NewParagraph>>showCaret (in category 'access') -----
+ showCaret
+ ^showCaret ifNil:[true]
+ !
Item was added:
+ ----- Method: NewParagraph>>showCaret: (in category 'access') -----
+ showCaret: aBool
+ showCaret := aBool
+ !
Item was added:
+ ----- Method: NewParagraph>>string (in category 'access') -----
+ string
+ ^ text string!
Item was added:
+ ----- Method: NewParagraph>>text (in category 'access') -----
+ text
+ ^ text!
Item was added:
+ ----- Method: NewParagraph>>textOwner: (in category 'access') -----
+ textOwner: ignored "See TextOnCurve"!
Item was added:
+ ----- Method: NewParagraph>>textStyle (in category 'access') -----
+ textStyle
+ ^ textStyle!
Item was added:
+ ----- Method: NewParagraph>>textStyle: (in category 'access') -----
+ textStyle: aTextStyle
+ "Set the style by which the receiver should display its text."
+ textStyle := aTextStyle!
Item was added:
+ ----- Method: NewParagraph>>textStyle:lines:text: (in category 'private') -----
+ textStyle: ts lines: l text: t
+ "Private -- just a service for deepCopy"
+ textStyle := ts.
+ lines := l.
+ text := t.!
Item was added:
+ ----- Method: NewParagraph>>wantsColumnBreaks (in category 'access') -----
+ wantsColumnBreaks
+
+ ^wantsColumnBreaks!
Item was added:
+ ----- Method: NewParagraph>>wantsColumnBreaks: (in category 'access') -----
+ wantsColumnBreaks: aBoolean
+
+ wantsColumnBreaks := aBoolean!
Item was added:
+ PluggableCanvas subclass: #NullCanvas
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !NullCanvas commentStamp: '<historical>' prior: 0!
+ A canvas which ignores all drawing commands.!
Item was added:
+ ----- Method: NullCanvas>>clipBy:during: (in category 'drawing-support') -----
+ clipBy: region during: aBlock
+ "do this in order that timing runs work better"
+ aBlock value: self!
Item was added:
+ ----- Method: NullCanvas>>clipRect (in category 'accessing') -----
+ clipRect
+ ^1 at 1 extent: 99 at 99!
Item was added:
+ ----- Method: NullCanvas>>copyClipRect: (in category 'copying') -----
+ copyClipRect: clipRect
+ "who cares what the clipping rectangle is?"
+ ^self!
Item was added:
+ ----- Method: NullCanvas>>extent (in category 'accessing') -----
+ extent
+ ^100 at 100!
Item was added:
+ ----- Method: NullCanvas>>form (in category 'accessing') -----
+ form
+ ^Form extent: self extent!
Item was added:
+ ----- Method: NullCanvas>>origin (in category 'accessing') -----
+ origin
+ ^0 at 0!
Item was added:
+ ----- Method: NullCanvas>>transformBy:clippingTo:during:smoothing: (in category 'drawing-support') -----
+ transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
+ "do this in order that timing runs work better"
+ aBlock value: self!
Item was added:
+ ----- Method: NullCanvas>>translateBy:during: (in category 'drawing-support') -----
+ translateBy: delta during: aBlock
+ "do this in order that timing runs work better"
+ aBlock value: self!
Item was added:
+ Object subclass: #NullEncoder
+ instanceVariableNames: 'target filterSelector'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: NullEncoder class>>defaultTarget (in category 'configuring') -----
+ defaultTarget
+ ^OrderedCollection new.
+ !
Item was added:
+ ----- Method: NullEncoder class>>filterSelector (in category 'configuring') -----
+ filterSelector
+ ^#writeOnFilterStream:
+ !
Item was added:
+ ----- Method: NullEncoder class>>process: (in category 'processing') -----
+ process:anObject
+ ^self stream process:anObject.
+
+ !
Item was added:
+ ----- Method: NullEncoder class>>stream (in category 'creation') -----
+ stream
+ ^self streamOn:self defaultTarget.
+ !
Item was added:
+ ----- Method: NullEncoder class>>stream: (in category 'creation') -----
+ stream:newTarget
+ ^self new initWithTarget:newTarget.
+ !
Item was added:
+ ----- Method: NullEncoder class>>streamOn: (in category 'creation') -----
+ streamOn:newTargetCollection
+ ^self new initWithTarget:newTargetCollection.
+ !
Item was added:
+ ----- Method: NullEncoder class>>streamOnFile: (in category 'creation') -----
+ streamOnFile:fileName
+ ^self new initWithTarget:(FileStream newFileNamed: fileName).
+ !
Item was added:
+ ----- Method: NullEncoder>>close (in category 'accessing') -----
+ close
+
+ ^target close.
+ !
Item was added:
+ ----- Method: NullEncoder>>contents (in category 'accessing') -----
+ contents
+ ^target contents.
+ !
Item was added:
+ ----- Method: NullEncoder>>forward: (in category 'writing') -----
+ forward:anObject
+ anObject ~= nil ifTrue:[target write:anObject].
+ !
Item was added:
+ ----- Method: NullEncoder>>initWithTarget: (in category 'initialization') -----
+ initWithTarget:aTarget
+ target := aTarget.
+ filterSelector := self class filterSelector.
+ ^self.
+ !
Item was added:
+ ----- Method: NullEncoder>>process: (in category 'processing') -----
+ process:anObject
+ self write:anObject.
+ ^self contents.!
Item was added:
+ ----- Method: NullEncoder>>target (in category 'accessing') -----
+ target
+ ^target.!
Item was added:
+ ----- Method: NullEncoder>>write: (in category 'writing') -----
+ write:anObject
+ filterSelector ifNil:[filterSelector:=self class filterSelector].
+ anObject ifNotNil: [anObject perform:filterSelector with:self].
+ !
Item was added:
+ ----- Method: NullEncoder>>writeObject: (in category 'writing') -----
+ writeObject:anObject
+ ^self forward:anObject.
+ !
Item was added:
+ ----- Method: Object>>asDraggableMorph (in category '*morphic') -----
+ asDraggableMorph
+ "Converts the receiver into a Morph suitable for dragging"
+ ^(StringMorph contents: (
+ (self respondsTo: #dragLabel)
+ ifTrue:[self dragLabel]
+ ifFalse:[self printString]))
+ color: Color white;
+ yourself!
Item was added:
+ ----- Method: Object>>asMorph (in category '*morphic') -----
+ asMorph
+ "Open a morph, as best one can, on the receiver"
+
+ ^ self asStringMorph
+
+ "
+ 234 asMorph
+ (ScriptingSystem formAtKey: #TinyMenu) asMorph
+ 'fred' asMorph
+ "
+
+ !
Item was added:
+ ----- Method: Object>>asStringMorph (in category '*morphic') -----
+ asStringMorph
+ "Open a StringMorph, as best one can, on the receiver"
+
+ ^ self asStringOrText asStringMorph
+ !
Item was added:
+ ----- Method: Object>>asTextMorph (in category '*morphic') -----
+ asTextMorph
+ "Open a TextMorph, as best one can, on the receiver"
+
+ ^ TextMorph new contentsAsIs: self asStringOrText
+ !
Item was added:
+ ----- Method: Object>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
+ hasContentsInExplorer
+
+ ^self basicSize > 0 or: [self class allInstVarNames isEmpty not]
+ !
Item was added:
+ ----- Method: Object>>isPluggableListMorph (in category '*morphic') -----
+ isPluggableListMorph
+ ^ false!
Item was added:
+ ----- Method: Object>>openAsMorph (in category '*morphic') -----
+ openAsMorph
+ "Open a morph, as best one can, on the receiver"
+
+ ^ self asMorph openInHand
+
+ "
+ 234 openAsMorph
+ (ScriptingSystem formAtKey: #TinyMenu) openAsMorph
+ 'fred' openAsMorph
+ "!
Item was added:
+ ----- Method: ObjectExplorer>>representsSameBrowseeAs: (in category '*morphic') -----
+ representsSameBrowseeAs: anotherObjectExplorer
+ ^ self rootObject == anotherObjectExplorer rootObject!
Item was added:
+ ListItemWrapper subclass: #ObjectExplorerWrapper
+ instanceVariableNames: 'itemName parent'
+ classVariableNames: 'ShowContentsInColumns'
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
+
+ !ObjectExplorerWrapper commentStamp: '<historical>' prior: 0!
+ Contributed by Bob Arning as part of the ObjectExplorer package.
+ !
Item was added:
+ ----- Method: ObjectExplorerWrapper class>>showContentsInColumns (in category 'preferences') -----
+ showContentsInColumns
+ <preference: 'Use columns in object explorer'
+ categoryList: #(Tools exploring)
+ description: 'If enabled, the object explorer will show key in the first column and values in the second column.'
+ type: #Boolean>
+ ^ ShowContentsInColumns ifNil: [true]!
Item was added:
+ ----- Method: ObjectExplorerWrapper class>>showContentsInColumns: (in category 'preferences') -----
+ showContentsInColumns: aBoolean
+
+ ShowContentsInColumns := aBoolean.!
Item was added:
+ ----- Method: ObjectExplorerWrapper class>>with:name:model: (in category 'as yet unclassified') -----
+ with: anObject name: aString model: aModel
+
+ ^self new
+ setItem: anObject name: aString model: aModel!
Item was added:
+ ----- Method: ObjectExplorerWrapper class>>with:name:model:parent: (in category 'as yet unclassified') -----
+ with: anObject name: aString model: aModel parent: aParent
+
+ ^self new
+ setItem: anObject name: aString model: aModel parent: aParent
+ !
Item was added:
+ ----- Method: ObjectExplorerWrapper>>asString (in category 'converting') -----
+ asString
+ | explorerString label separator |
+ explorerString :=
+ [self object asExplorerString]
+ on: Error
+ do: ['<error: ', self object class name, ' in asExplorerString: evaluate "' , self itemName , ' asExplorerString" to debug>'].
+ (explorerString includes: Character cr)
+ ifTrue: [explorerString := explorerString withSeparatorsCompacted].
+
+ label := self itemName ifNil: [''].
+ (label includes: Character cr)
+ ifTrue: [label := label withSeparatorsCompacted].
+
+ separator := self class showContentsInColumns
+ ifTrue: [String tab]
+ ifFalse: [label ifEmpty: [''] ifNotEmpty: [': ']].
+
+ ^ '{1}{2}{3}' format: {label. separator. explorerString}!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>contents (in category 'accessing') -----
+ contents
+
+ (self object respondsTo: #explorerContents) ifTrue: [
+ ^ self object explorerContents
+ do: [:wrapper | wrapper parent: self];
+ yourself].
+ "For all others, show named vars first, then indexed vars"
+ ^(self object class allInstVarNames asOrderedCollection withIndexCollect: [:each :index |
+ self class
+ with: (self object instVarAt: index)
+ name: each
+ model: self object
+ parent: self]) ,
+ ((1 to: self object basicSize) collect: [:index |
+ self class
+ with: (self object basicAt: index)
+ name: index printString
+ model: self object
+ parent: self])!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>hasContents (in category 'accessing') -----
+ hasContents
+
+ ^ self object hasContentsInExplorer
+
+ !
Item was added:
+ ----- Method: ObjectExplorerWrapper>>icon (in category 'accessing') -----
+ icon
+ "Answer a form to be used as icon"
+ ^ Preferences visualExplorer
+ ifTrue: [(self object iconOrThumbnailOfSize: 12)
+ ifNil: [self class showContentsInColumns
+ ifTrue: [ToolIcons iconNamed: #blank]
+ ifFalse: [nil]]]
+ ifFalse: [nil]!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>itemName (in category 'accessing') -----
+ itemName
+
+ ^ self item key!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>object (in category 'accessing') -----
+ object
+
+ ^ self item value!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>object: (in category 'accessing') -----
+ object: anObject
+
+ self item value: anObject.!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>parent (in category 'accessing') -----
+ parent
+ ^ parent!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>parent: (in category 'accessing') -----
+ parent: aWrapper
+
+ parent := aWrapper.!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>refresh (in category 'monitoring') -----
+ refresh
+ "hack to refresh item given an object and a string that is either an index or an instance variable name."
+
+ self parent ifNil: [^ self].
+ [ | index |
+ (model class allInstVarNames includes: self itemName)
+ ifTrue: [ self object: (model instVarNamed: self itemName) ]
+ ifFalse: [ index := self itemName asNumber.
+ (index between: 1 and: model basicSize) ifTrue: [ self object: (model basicAt: index)]]
+ ] on: Error do: [ :ex | self object: nil ]!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>setItem:name:model: (in category 'initialization') -----
+ setItem: anObject name: aString model: aModel
+
+ self setItem: aString -> anObject model: aModel.!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>setItem:name:model:parent: (in category 'initialization') -----
+ setItem: anObject name: aString model: aModel parent: itemParent
+
+ self parent: itemParent.
+ self setItem: anObject name: aString model: aModel!
Item was added:
+ ----- Method: OrderedCollection>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
+ hasContentsInExplorer
+
+ ^self isEmpty not!
Item was added:
+ ----- Method: OrientedFillStyle>>addFillStyleMenuItems:hand:from: (in category '*Morphic-Balloon') -----
+ addFillStyleMenuItems: aMenu hand: aHand from: aMorph
+ "Add the items for changing the current fill style of the receiver"
+ aMenu add: 'change origin' translated target: self selector: #changeOriginIn:event: argument: aMorph.
+ aMenu add: 'change orientation' translated target: self selector: #changeOrientationIn:event: argument: aMorph.!
Item was added:
+ ----- Method: OrientedFillStyle>>changeOrientationIn:event: (in category '*Morphic-Balloon') -----
+ changeOrientationIn: aMorph event: evt
+ "Interactively change the origin of the receiver"
+ | handle |
+ handle := HandleMorph new forEachPointDo:[:pt|
+ self direction: pt - self origin.
+ self normal: nil.
+ aMorph changed].
+ evt hand attachMorph: handle.
+ handle startStepping.!
Item was added:
+ ----- Method: OrientedFillStyle>>changeOriginIn:event: (in category '*Morphic-Balloon') -----
+ changeOriginIn: aMorph event: evt
+ "Interactively change the origin of the receiver"
+ | handle |
+ handle := HandleMorph new forEachPointDo:[:pt|
+ self origin: pt.
+ aMorph changed].
+ evt hand attachMorph: handle.
+ handle startStepping.!
Item was added:
+ BorderedMorph subclass: #PasteUpMorph
+ instanceVariableNames: 'presenter model cursor padding backgroundMorph turtleTrailsForm turtlePen lastTurtlePositions isPartsBin indicateCursor wantsMouseOverHalos worldState griddingOn'
+ classVariableNames: 'DisableDeferredUpdates MinCycleLapse StillAlive WindowEventHandler'
+ poolDictionaries: ''
+ category: 'Morphic-Worlds'!
+
+ !PasteUpMorph commentStamp: '<historical>' prior: 0!
+ A morph whose submorphs comprise a paste-up of rectangular subparts which "show through". Anything called a 'Playfield' is a PasteUpMorph.
+
+ Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided.
+
+ A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. Morph subclasses that have specialized menus (BookMorph) build them in the message addBookMenuItemsTo:hand:. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu.
+
+ presenter A Presenter in charge of stopButton stepButton and goButton,
+ mouseOverHalosEnabled soundsEnabled fenceEnabled coloredTilesEnabled.
+ model <not used>
+ cursor ??
+ padding ??
+ backgroundMorph A Form that covers the background.
+ turtleTrailsForm Moving submorphs may leave trails on this form.
+ turtlePen Draws the trails.
+ lastTurtlePositions A Dictionary of (aPlayer -> aPoint) so turtle trails can be drawn
+ only once each step cycle. The point is the start of the current stroke.
+ isPartsBin If true, every object dragged out is copied.
+ autoLineLayout ??
+ indicateCursor ??
+ resizeToFit ??
+ wantsMouseOverHalos If true, simply moving the cursor over a submorph brings up its halo.
+ worldState If I am also a World, keeps the hands, damageRecorder, stepList etc.
+ griddingOn If true, submorphs are on a grid
+
+ !
Item was added:
+ ----- Method: PasteUpMorph class>>MinCycleLapse: (in category 'project') -----
+ MinCycleLapse: milliseconds
+ "set the minimum amount of time that may transpire between two calls to doOneCycle"
+ MinCycleLapse := milliseconds ifNotNil: [ milliseconds rounded ].!
Item was added:
+ ----- Method: PasteUpMorph class>>authoringPrototype (in category 'scripting') -----
+ authoringPrototype
+ "Answer an instance of the receiver suitable for placing in a parts bin for authors"
+
+ | proto |
+ proto := self new markAsPartsDonor.
+ proto color: Color green muchLighter; extent: 100 @ 80; borderColor: (Color r: 0.645 g: 0.935 b: 0.161).
+ proto extent: 300 @ 240.
+ proto beSticky.
+ ^ proto!
Item was added:
+ ----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') -----
+ defaultNameStemForInstances
+ "Answer a basis for names of default instances of the receiver"
+ ^ 'playfield'!
Item was added:
+ ----- Method: PasteUpMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Playfield'
+ categories: #('Presentation')
+ documentation: 'A place for assembling parts or for staging animations'!
Item was added:
+ ----- Method: PasteUpMorph class>>disableDeferredUpdates (in category 'project') -----
+ disableDeferredUpdates
+
+ ^DisableDeferredUpdates ifNil: [DisableDeferredUpdates := false]
+ !
Item was added:
+ ----- Method: PasteUpMorph class>>disableDeferredUpdates: (in category 'project') -----
+ disableDeferredUpdates: aBoolean
+ "If the argument is true, disable deferred screen updating."
+ "Details: When deferred updating is used, Morphic performs double-buffered screen updates by telling the VM to de-couple the Display from the hardware display buffer, drawing directly into the Display, and then forcing the changed regions of the Display to be copied to the screen. This saves both time (an extra BitBlt is avoided) and space (an extra display buffer is avoided). However, on platforms on which the Display points directly to the hardware screen buffer, deferred updating can't be used (you'd see ugly flashing as the layers of the drawing were assembled). In this case, the drawing is composited into an offscreen FormCanvas and then copied to the hardware display buffer."
+
+ DisableDeferredUpdates := aBoolean.
+ !
Item was added:
+ ----- Method: PasteUpMorph class>>newWorldForProject: (in category 'project') -----
+ newWorldForProject: projectOrNil
+ "Return a new pasteUpMorph configured as a world (ie project notNil).
+ projectOrNil is no longer used."
+
+ ^ self new initForProject: WorldState new!
Item was added:
+ ----- Method: PasteUpMorph class>>shutDown (in category 'system startup') -----
+ shutDown
+
+ World ifNotNil:[
+ World triggerEvent: #aboutToLeaveWorld.
+ ].!
Item was added:
+ ----- Method: PasteUpMorph class>>startUp (in category 'system startup') -----
+ startUp
+
+ World ifNotNil:[
+ World restoreMorphicDisplay.
+ World triggerEvent: #aboutToEnterWorld.
+ ].!
Item was added:
+ ----- Method: PasteUpMorph>>abandonAllHalos (in category 'world state') -----
+ abandonAllHalos
+ self flag: #arNote. "Remove the method"
+ ^self deleteAllHalos!
Item was added:
+ ----- Method: PasteUpMorph>>abandonCostumeHistory (in category 'misc') -----
+ abandonCostumeHistory
+ self allMorphsDo:
+ [:m | m player ifNotNil: [m player forgetOtherCostumes]]!
Item was added:
+ ----- Method: PasteUpMorph>>acceptDroppingMorph:event: (in category 'dropping/grabbing') -----
+ acceptDroppingMorph: dropped event: evt
+ "The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied"
+
+ | aMorph |
+ aMorph := self morphToDropFrom: dropped.
+ self isWorldMorph
+ ifTrue:["Add the given morph to this world and start stepping it if it wants to be."
+ self addMorphFront: aMorph.
+ (aMorph fullBounds intersects: self viewBox) ifFalse:
+ [Beeper beep. aMorph position: self bounds center]]
+ ifFalse:[super acceptDroppingMorph: aMorph event: evt].
+
+ aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]].
+ aMorph allMorphsDo: "Establish any penDown morphs in new world"
+ [:m | | tfm mm |
+ m player ifNotNil:
+ [m player getPenDown ifTrue:
+ [((mm := m player costume) notNil and: [(tfm := mm owner transformFrom: self) notNil])
+ ifTrue: [self noteNewLocation: (tfm localPointToGlobal: mm referencePosition)
+ forPlayer: m player]]]].
+
+ self isPartsBin
+ ifTrue:
+ [aMorph isPartsDonor: true.
+ aMorph stopSteppingSelfAndSubmorphs.
+ aMorph suspendEventHandler]
+ ifFalse:
+ [self world startSteppingSubmorphsOf: aMorph].
+
+ " self presenter morph: aMorph droppedIntoPasteUpMorph: self."
+
+ self showingListView ifTrue:
+ [self sortSubmorphsBy: (self valueOfProperty: #sortOrder).
+ self currentWorld abandonAllHalos].
+
+ self bringTopmostsToFront.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>accommodateFlap: (in category 'flaps') -----
+ accommodateFlap: aFlapTab
+ "Shift submorphs over, if appropriate"
+ | offset |
+ aFlapTab slidesOtherObjects ifTrue:
+ [offset := self offsetForAccommodating: aFlapTab referent extent onEdge: aFlapTab edgeToAdhereTo.
+ self shiftSubmorphsBy: offset]!
Item was added:
+ ----- Method: PasteUpMorph>>activateObjectsTool (in category 'world menu') -----
+ activateObjectsTool
+ "Offer the user a parts bin of morphs -- if one already exists, bring it to the front and flash its border beckoningly; if none exists yet, create a new one and place it in the center of the screen"
+
+ | anObjectTool |
+ submorphs do:
+ [:aMorph | (aMorph renderedMorph isKindOf: ObjectsTool)
+ ifTrue:
+ [aMorph comeToFront.
+ aMorph flash.
+ ^ self]].
+ "None found, so create one"
+
+ anObjectTool := ObjectsTool newStandAlone.
+ self addMorphFront: anObjectTool.
+ anObjectTool fullBounds.
+ anObjectTool center: self center
+
+ "ActiveWorld activateObjectsTool"!
Item was added:
+ ----- Method: PasteUpMorph>>activeHand (in category 'structure') -----
+ activeHand
+
+ ^ worldState ifNotNil: [worldState activeHand] ifNil: [super activeHand]!
Item was added:
+ ----- Method: PasteUpMorph>>activeHand: (in category 'world state') -----
+ activeHand: aHandMorph
+ "temporarily retained for old main event loops"
+
+ worldState activeHand: aHandMorph.
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>adaptedToWorld: (in category 'initialization') -----
+ adaptedToWorld: aWorld
+ "If I refer to a world or a hand, return the corresponding items in the new world."
+ self isWorldMorph ifTrue:[^aWorld].!
Item was added:
+ ----- Method: PasteUpMorph>>addAlarm:withArguments:for:at: (in category 'alarms-scheduler') -----
+ addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime
+ "Add a new alarm with the given set of parameters"
+ worldState addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime.!
Item was added:
+ ----- Method: PasteUpMorph>>addAllMorphs: (in category 'submorphs-add/remove') -----
+ addAllMorphs: array
+
+ super addAllMorphs: array.
+ self isWorldMorph
+ ifTrue: [array do: [:m | self startSteppingSubmorphsOf: m]].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>addCenteredAtBottom:offset: (in category 'layout') -----
+ addCenteredAtBottom: aMorph offset: anOffset
+ "Add aMorph beneath all other morphs currently in the receiver, centered horizontally, with the vertical offset from the bottom of the previous morph given by anOffset"
+ | curBot |
+ curBot := 0.
+ submorphs do: [:m | curBot := curBot max: m bottom].
+ self addMorphBack: aMorph.
+ aMorph position: ((self center x - (aMorph width // 2)) @ (curBot + anOffset))!
Item was added:
+ ----- Method: PasteUpMorph>>addCustomMenuItems:hand: (in category 'menu & halo') -----
+ addCustomMenuItems: menu hand: aHandMorph
+ "Add morph-specific menu itemns to the menu for the hand"
+ super addCustomMenuItems: menu hand: aHandMorph.
+
+ menu addLine.
+ Preferences noviceMode
+ ifFalse: [
+ self addStackMenuItems: menu hand: aHandMorph.
+ self addPenMenuItems: menu hand: aHandMorph.
+ self addPlayfieldMenuItems: menu hand: aHandMorph].
+
+ self isWorldMorph
+ ifTrue: [
+ menu addLine.
+ Preferences noviceMode
+ ifFalse: [(owner isKindOf: BOBTransformationMorph)
+ ifTrue: [self addScalingMenuItems: menu hand: aHandMorph]].
+ menu addUpdating: #showWorldMainDockingBarString action: #toggleShowWorldMainDockingBar.
+
+ Flaps sharedFlapsAllowed ifTrue: [
+ menu
+ addUpdating: #suppressFlapsString
+ target: Project current
+ action: #toggleFlapsSuppressed.
+ ].
+
+ Preferences noviceMode ifFalse: [| twm |
+ menu addLine.
+
+ twm := TheWorldMenu new.
+ twm world: self project: Project current hand: aHandMorph.
+
+ menu add: 'old desktop menu... (W)' translated subMenu: twm buildWorldMenu.
+ ].
+ ].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>addGlobalFlaps (in category 'flaps') -----
+ addGlobalFlaps
+ "Must make global flaps adapt to world. Do this even if not shown, so the old world will not be pointed at by the flaps."
+
+ | use thisWorld |
+ use := Flaps sharedFlapsAllowed.
+ Project current flapsSuppressed ifTrue: [use := false].
+ "Smalltalk isMorphic ifFalse: [use := false]."
+ thisWorld := use
+ ifTrue: [self]
+ ifFalse: [PasteUpMorph new initForProject: "fake to be flap owner"
+ WorldState new;
+ bounds: (0 at 0 extent: 4000 at 4000);
+ viewBox: (0 at 0 extent: 4000 at 4000)].
+
+ Flaps globalFlapTabsIfAny do: [:aFlapTab |
+ (Project current isFlapEnabled: aFlapTab) ifTrue:
+ [(aFlapTab world == thisWorld) ifFalse:
+ [thisWorld addMorphFront: aFlapTab.
+ aFlapTab adaptToWorld: thisWorld]. "always do"
+ use ifTrue:
+ [aFlapTab spanWorld.
+ aFlapTab adjustPositionAfterHidingFlap.
+ aFlapTab flapShowing ifTrue: [aFlapTab showFlap]]]]!
Item was added:
+ ----- Method: PasteUpMorph>>addHand: (in category 'world state') -----
+ addHand: aHandMorph
+ "Add the given hand to the list of hands for this world."
+
+ aHandMorph owner ifNotNil:[aHandMorph owner removeHand: aHandMorph].
+ worldState addHand: aHandMorph.
+ aHandMorph privateOwner: self.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>addMorph:centeredNear: (in category 'world state') -----
+ addMorph: aMorph centeredNear: aPoint
+ "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world."
+
+ | trialRect delta |
+ trialRect := Rectangle center: aPoint extent: aMorph fullBounds extent.
+ delta := trialRect amountToTranslateWithin: bounds.
+ aMorph position: trialRect origin + delta.
+ self addMorph: aMorph.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>addMorphFront: (in category 'submorphs-add/remove') -----
+ addMorphFront: aMorph
+
+ ^self addMorphInFrontOfLayer: aMorph
+ !
Item was added:
+ ----- Method: PasteUpMorph>>addMorphInLayer: (in category 'WiW support') -----
+ addMorphInLayer: aMorph
+ super addMorphInLayer: aMorph.
+ aMorph wantsToBeTopmost ifFalse:[self bringTopmostsToFront].!
Item was added:
+ ----- Method: PasteUpMorph>>addMorphsAndModel: (in category 'world state') -----
+ addMorphsAndModel: aMorphOrList
+ "Dump in submorphs, model, and stepList from aMorphOrList. Used to bring a world, paste-up, or other morph in from an object file."
+
+ aMorphOrList isMorph
+ ifTrue:
+ [aMorphOrList isWorldMorph
+ ifFalse:
+ ["one morph, put on hand"
+
+ "aMorphOrList installModelIn: self. a chance to install model pointers"
+
+ aMorphOrList privateOwner: nil.
+ self firstHand attachMorph: aMorphOrList.
+ self startSteppingSubmorphsOf: aMorphOrList]
+ ifTrue:
+ [model isNil
+ ifTrue: [self setModel: aMorphOrList modelOrNil]
+ ifFalse:
+ [aMorphOrList modelOrNil ifNotNil:
+ [aMorphOrList modelOrNil privateOwner: nil.
+ self addMorph: aMorphOrList modelOrNil]].
+ aMorphOrList privateSubmorphs reverseDo:
+ [:m |
+ m privateOwner: nil.
+ self addMorph: m.
+ m changed].
+ (aMorphOrList instVarNamed: 'stepList')
+ do: [:entry | entry first startSteppingIn: self]]]
+ ifFalse:
+ ["list, add them all"
+
+ aMorphOrList reverseDo:
+ [:m |
+ m privateOwner: nil.
+ self addMorph: m.
+ self startSteppingSubmorphsOf: m. "It may not want this!!"
+ m changed]]!
Item was added:
+ ----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') -----
+ addPenMenuItems: menu hand: aHandMorph
+ "Add a pen-trails-within submenu to the given menu"
+
+ menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu!
Item was added:
+ ----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') -----
+ addPenTrailsMenuItemsTo: aMenu
+ "Add items relating to pen trails to aMenu"
+
+ | oldTarget |
+ oldTarget := aMenu defaultTarget.
+ aMenu defaultTarget: self.
+ aMenu add: 'clear pen trails' translated action: #clearTurtleTrails.
+ aMenu addLine.
+ aMenu add: 'all pens up' translated action: #liftAllPens.
+ aMenu add: 'all pens down' translated action: #lowerAllPens.
+ aMenu addLine.
+ aMenu add: 'all pens show lines' translated action: #linesForAllPens.
+ aMenu add: 'all pens show arrowheads' translated action: #arrowsForAllPens.
+ aMenu add: 'all pens show arrows' translated action: #linesAndArrowsForAllPens.
+ aMenu add: 'all pens show dots' translated action: #dotsForAllPens.
+ aMenu defaultTarget: oldTarget!
Item was added:
+ ----- Method: PasteUpMorph>>addPlayfieldMenuItems:hand: (in category 'menu & halo') -----
+ addPlayfieldMenuItems: menu hand: aHandMorph
+ "Add playfield-related items to the menu"
+
+ menu add: 'playfield options...' translated target: self action: #presentPlayfieldMenu.
+ (self hasProperty: #donorTextMorph) ifTrue:
+ [menu add: 'send contents back to donor' translated action: #sendTextContentsBackToDonor]!
Item was added:
+ ----- Method: PasteUpMorph>>addRemoteClient: (in category 'Nebraska') -----
+ addRemoteClient: aClient
+ self addHand: aClient hand.
+ worldState addRemoteCanvas: aClient canvas.
+ aClient canvas fullDrawMorph: self.
+ self changed. "force a redraw"
+ !
Item was added:
+ ----- Method: PasteUpMorph>>addScalingMenuItems:hand: (in category 'menu & halo') -----
+ addScalingMenuItems: menu hand: aHandMorph
+
+ | subMenu |
+
+ (subMenu := MenuMorph new)
+ defaultTarget: self;
+ add: 'show application view' translated action: #showApplicationView;
+ add: 'show factory view' translated action: #showFactoryView;
+ add: 'show whole world view' translated action: #showFullView;
+ add: 'expand' translated action: #showExpandedView;
+ add: 'reduce' translated action: #showReducedView;
+ addLine;
+ add: 'define application view' translated action: #defineApplicationView;
+ add: 'define factory view' translated action: #defineFactoryView.
+ menu
+ add: 'world scale and clip...' translated
+ subMenu: subMenu!
Item was added:
+ ----- Method: PasteUpMorph>>addStackMenuItems:hand: (in category 'menu & halo') -----
+ addStackMenuItems: menu hand: aHandMorph
+ "Add appropriate stack-related items to the given menu"
+
+ self isStackBackground
+ ifTrue:
+ [menu add: 'card & stack...' target: self action: #presentCardAndStackMenu]!
Item was added:
+ ----- Method: PasteUpMorph>>addUndoItemsTo: (in category 'world menu') -----
+ addUndoItemsTo: aWorldMenu
+ "Add undo-related items to the given menu. Will add zero, one or two items, depending on the settings of the #useUndo and #infiniteUndo preferences"
+
+ Preferences useUndo ifFalse: [^ self].
+ Preferences infiniteUndo
+ ifFalse:
+ [aWorldMenu addUpdating: #undoOrRedoMenuWording target: self commandHistory action: #undoOrRedoCommand]
+ ifTrue:
+ [aWorldMenu addUpdating: #undoMenuWording target: self commandHistory action: #undoLastCommand.
+ aWorldMenu addUpdating: #redoMenuWording target: self commandHistory action: #redoNextCommand.
+ self flag: #deferred. "The following feature to be unblocked in due course"
+ "aWorldMenu add: 'undo to...' target: self commandHistory action: #undoTo"].
+ aWorldMenu addLine!
Item was added:
+ ----- Method: PasteUpMorph>>addWorldHaloMenuItemsTo:hand: (in category 'menu & halo') -----
+ addWorldHaloMenuItemsTo: aMenu hand: aHandMorph
+ "Add standard halo items to the menu, given that the receiver is a World"
+
+ | unlockables |
+ self addFillStyleMenuItems: aMenu hand: aHandMorph.
+ self addLayoutMenuItems: aMenu hand: aHandMorph.
+
+ aMenu addLine.
+ self addWorldToggleItemsToHaloMenu: aMenu.
+ aMenu addLine.
+ self addCopyItemsTo: aMenu.
+ self addPlayerItemsTo: aMenu.
+ self addExportMenuItems: aMenu hand: aHandMorph.
+ self addStackItemsTo: aMenu.
+ self addMiscExtrasTo: aMenu.
+
+ Preferences noviceMode ifFalse:
+ [self addDebuggingItemsTo: aMenu hand: aHandMorph].
+
+ aMenu addLine.
+ aMenu defaultTarget: self.
+
+ aMenu addLine.
+
+ unlockables := self submorphs select:
+ [:m | m isLocked].
+ unlockables size = 1 ifTrue:
+ [aMenu add: ('unlock "{1}"' translated format:{unlockables first externalName})action: #unlockContents].
+ unlockables size > 1 ifTrue:
+ [aMenu add: 'unlock all contents' translated action: #unlockContents.
+ aMenu add: 'unlock...' translated action: #unlockOneSubpart].
+
+ aMenu defaultTarget: aHandMorph.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>addWorldToggleItemsToHaloMenu: (in category 'menu & halo') -----
+ addWorldToggleItemsToHaloMenu: aMenu
+ "Add toggle items for the world to the halo menu"
+
+ #(
+ (hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me')
+ (roundedCornersString toggleCornerRounding 'whether the world should have rounded corners')) do:
+
+ [:trip | aMenu addUpdating: trip first action: trip second.
+ aMenu balloonTextForLastItem: trip third]!
Item was added:
+ ----- Method: PasteUpMorph>>allMorphsDo: (in category 'submorphs-accessing') -----
+ allMorphsDo: aBlock
+ "Enumerate all morphs in the world, including those held in hands."
+
+ super allMorphsDo: aBlock.
+ self isWorldMorph
+ ifTrue: [worldState handsReverseDo: [:h | h allMorphsDo: aBlock]].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>allNonFlapRelatedSubmorphs (in category 'world state') -----
+ allNonFlapRelatedSubmorphs
+ "Answer all non-window submorphs that are not flap-related"
+
+ ^submorphs
+ select: [:m | (m isSystemWindow) not and: [m wantsToBeTopmost not]]!
Item was added:
+ ----- Method: PasteUpMorph>>allScriptEditors (in category 'misc') -----
+ allScriptEditors
+ ^ self allMorphs select:
+ [:s | s isScriptEditorMorph]!
Item was added:
+ ----- Method: PasteUpMorph>>allScriptors (in category 'misc') -----
+ allScriptors
+ "Answer a list of all active scriptors running on behalf of the receiver. This is a hook used in past demos and with a future life which however presently is vacuous"
+
+ ^ #()
+ "
+ ^ self allMorphs select: [:m | m isKindOf: Scriptor]"!
Item was added:
+ ----- Method: PasteUpMorph>>allTileScriptingElements (in category 'scripting') -----
+ allTileScriptingElements
+ "Answer a list of all the morphs that pertain to tile-scripting. A sledge-hammer"
+
+ | all morphs |
+ morphs := IdentitySet new: 400.
+ self allMorphsAndBookPagesInto: morphs.
+ all := morphs select: [:s | s isTileScriptingElement].
+ " self closedViewerFlapTabs do:
+ [:aTab | all addAll: aTab referent allTileScriptingElements].
+ "
+ ^ all asOrderedCollection!
Item was added:
+ ----- Method: PasteUpMorph>>alwaysShowThumbnail (in category 'misc') -----
+ alwaysShowThumbnail
+ ^ self hasProperty: #alwaysShowThumbnail!
Item was added:
+ ----- Method: PasteUpMorph>>assureFlapTabsFitOnScreen (in category 'flaps') -----
+ assureFlapTabsFitOnScreen
+ self flapTabs do:
+ [:m | m fitOnScreen]!
Item was added:
+ ----- Method: PasteUpMorph>>assureFlapWidth: (in category 'accessing') -----
+ assureFlapWidth: requestedWidth
+ | tab |
+ self width: requestedWidth.
+ tab := self flapTab ifNil:[^self].
+ tab flapShowing ifTrue:[tab hideFlap; showFlap].!
Item was added:
+ ----- Method: PasteUpMorph>>assureNotPaintingElse: (in category 'world state') -----
+ assureNotPaintingElse: aBlock
+ "If painting is already underway in the receiver, put up an informer to that effect and evalute aBlock"
+ self removeModalWindow.
+ self sketchEditorOrNil ifNotNil:
+ [self inform: 'Sorry, you can only paint
+ one object at a time' translated.
+ Cursor normal show.
+ ^ aBlock value]
+ !
Item was added:
+ ----- Method: PasteUpMorph>>assureNotPaintingEvent: (in category 'world state') -----
+ assureNotPaintingEvent: evt
+ "If painting is already underway
+ in the receiver, put up an informer to that effect and evalute aBlock"
+ | editor |
+ (editor := self sketchEditorOrNil) ifNotNil:[
+ editor save: evt.
+ Cursor normal show.
+ ].!
Item was added:
+ ----- Method: PasteUpMorph>>assuredCanvas (in category 'world state') -----
+ assuredCanvas
+
+ ^worldState assuredCanvas!
Item was added:
+ ----- Method: PasteUpMorph>>autoLineLayout (in category 'options') -----
+ autoLineLayout
+ | layout |
+ layout := self layoutPolicy ifNil:[^false].
+ layout isTableLayout ifFalse:[^false].
+ self listDirection == #leftToRight ifFalse:[^false].
+ self wrapDirection == #topToBottom ifFalse:[^false].
+ ^true!
Item was added:
+ ----- Method: PasteUpMorph>>autoLineLayout: (in category 'options') -----
+ autoLineLayout: aBoolean
+ "Make the receiver be viewed with auto-line-layout, which means that its submorphs will be laid out left-to-right and then top-to-bottom in the manner of a word processor, or (if aBoolean is false,) cease applying auto-line-layout"
+
+ aBoolean ifTrue:
+ [self viewingNormally ifTrue: [self saveBoundsOfSubmorphs]].
+ aBoolean ifTrue:[
+ self layoutPolicy: TableLayout new.
+ self layoutInset: 8; cellInset: 4.
+ self listDirection: #leftToRight; wrapDirection: #topToBottom.
+ ] ifFalse:[
+ self layoutPolicy: nil.
+ self layoutInset: 0; cellInset: 0.
+ ].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>autoLineLayoutString (in category 'menu & halo') -----
+ autoLineLayoutString
+ "Answer the string to be shown in a menu to represent the
+ auto-line-layout status"
+ ^ (self autoLineLayout
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'auto-line-layout' translated!
Item was added:
+ ----- Method: PasteUpMorph>>automaticPhraseExpansion (in category 'dropping/grabbing') -----
+ automaticPhraseExpansion
+ ^ self hasProperty: #automaticPhraseExpansion!
Item was added:
+ ----- Method: PasteUpMorph>>automaticViewing (in category 'e-toy support') -----
+ automaticViewing
+ ^ self hasProperty: #automaticViewing!
Item was added:
+ ----- Method: PasteUpMorph>>beWorldForProject: (in category 'world state') -----
+ beWorldForProject: aProject
+
+ self privateOwner: nil.
+ worldState := WorldState new.
+ self addHand: HandMorph new.
+ self setProperty: #automaticPhraseExpansion toValue: true.
+ self setProperty: #optimumExtentFromAuthor toValue: Display extent.
+ self startSteppingSubmorphsOf: self!
Item was added:
+ ----- Method: PasteUpMorph>>becomeActiveDuring: (in category 'initialization') -----
+ becomeActiveDuring: aBlock
+ "Make the receiver the ActiveWorld during the evaluation of aBlock.
+ Note that this method does deliberately *not* use #ensure: to prevent
+ re-installation of the world on project switches."
+ | priorWorld priorHand priorEvent |
+ priorWorld := ActiveWorld.
+ priorHand := ActiveHand.
+ priorEvent := ActiveEvent.
+ ActiveWorld := self.
+ ActiveHand := self hands first. "default"
+ ActiveEvent := nil. "not in event cycle"
+ aBlock
+ on: Error
+ do: [:ex |
+ ActiveWorld := priorWorld.
+ ActiveEvent := priorEvent.
+ ActiveHand := priorHand.
+ ex pass]!
Item was added:
+ ----- Method: PasteUpMorph>>behaveLikeHolder (in category 'options') -----
+ behaveLikeHolder
+
+ self vResizeToFit: true; autoLineLayout: true; indicateCursor: true!
Item was added:
+ ----- Method: PasteUpMorph>>behaveLikeHolder: (in category 'options') -----
+ behaveLikeHolder: aBoolean
+ "Change the receiver's viewing properties such that they conform to what we commonly call a Holder, viz: resize-to-fit, do auto-line-layout, and indicate the 'cursor'"
+
+ self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
+ !
Item was added:
+ ----- Method: PasteUpMorph>>behavingLikeAHolder (in category 'options') -----
+ behavingLikeAHolder
+ "Answer whether the receiver is currently behaving like a Holder"
+
+ ^ self resizeToFit and: [self indicateCursor and: [self autoLineLayout]]!
Item was added:
+ ----- Method: PasteUpMorph>>bringTopmostsToFront (in category 'flaps') -----
+ bringTopmostsToFront
+ submorphs
+ select:[:m| m wantsToBeTopmost]
+ thenDo:[:m| self addMorphInLayer: m].!
Item was added:
+ ----- Method: PasteUpMorph>>bringWindowsFullOnscreen (in category 'world menu') -----
+ bringWindowsFullOnscreen
+ "Make ever SystemWindow on the desktop be totally on-screen, whenever possible."
+
+ (SystemWindow windowsIn: self satisfying: [:w | true]) do:
+ [:aWindow |
+ aWindow right: (aWindow right min: bounds right).
+ aWindow bottom: (aWindow bottom min: bounds bottom).
+ aWindow left: (aWindow left max: bounds left).
+ aWindow top: (aWindow top max: bounds top)]!
Item was added:
+ ----- Method: PasteUpMorph>>browseAllScriptsTextually (in category 'world menu') -----
+ browseAllScriptsTextually
+ "Put up a browser showing all scripts in the project textually"
+
+ self presenter browseAllScriptsTextually
+
+ "ActiveWorld browseAllScriptsTextually"!
Item was added:
+ ----- Method: PasteUpMorph>>buildDebugMenu: (in category 'menu & halo') -----
+ buildDebugMenu: aHandMorph
+ | aMenu |
+ aMenu := super buildDebugMenu: aHandMorph.
+ aMenu add: 'abandon costume history' translated target: self action: #abandonCostumeHistory.
+ ^ aMenu!
Item was added:
+ ----- Method: PasteUpMorph>>buildWorldMenu: (in category 'world menu') -----
+ buildWorldMenu: evt
+ ^(TheWorldMenu new
+ world: self
+ project: (self project ifNil: [Project current]) "mvc??"
+ hand: evt hand) buildWorldMenu.!
Item was added:
+ ----- Method: PasteUpMorph>>cachedOrNewThumbnailFrom: (in category 'misc') -----
+ cachedOrNewThumbnailFrom: newThumbnail
+ "If I have a cached thumbnail, and it is of the desired extent, then ruturn it.
+ Otherwise produce one in newThumbnail and return it (after caching).
+ This code parallels what happens in page: to match resultant extent."
+ | cachedThumbnail scale ext |
+ scale := newThumbnail height / self fullBounds height.
+ ext := (self fullBounds extent * scale) truncated.
+ (cachedThumbnail := self valueOfProperty: #cachedThumbnail) ifNotNil:
+ [cachedThumbnail extent = ext ifTrue: [^ cachedThumbnail]].
+ self setProperty: #cachedThumbnail toValue: (newThumbnail page: self).
+ ^ newThumbnail!
Item was added:
+ ----- Method: PasteUpMorph>>canHaveFillStyles (in category 'visual properties') -----
+ canHaveFillStyles
+ "Return true if the receiver can have general fill styles; not just colors.
+ This method is for gradually converting old morphs."
+ ^ true!
Item was added:
+ ----- Method: PasteUpMorph>>canvas (in category 'project state') -----
+ canvas
+
+ ^ worldState canvas!
Item was added:
+ ----- Method: PasteUpMorph>>canvas: (in category 'project state') -----
+ canvas: aCanvas
+ "Set this world's canvas"
+
+ worldState canvas: aCanvas.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>cartesianOrigin (in category 'misc') -----
+ cartesianOrigin
+ ^ self originAtCenter
+ ifFalse:
+ [self bottomLeft]
+ ifTrue:
+ [self center]!
Item was added:
+ ----- Method: PasteUpMorph>>checkCurrentHandForObjectToPaste (in category 'world state') -----
+ checkCurrentHandForObjectToPaste
+
+ | response |
+ self primaryHand pasteBuffer ifNil: [^self].
+ response := UIManager default chooseFrom: #('Delete' 'Keep')
+ title: 'Hand is holding a Morph in its paste buffer:\' withCRs,
+ self primaryHand pasteBuffer printString.
+ response = 1 ifTrue: [self primaryHand pasteBuffer: nil].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>checkCurrentHandForObjectToPaste2 (in category 'world state') -----
+ checkCurrentHandForObjectToPaste2
+
+ self primaryHand pasteBuffer ifNil: [^self].
+ self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs,
+ self primaryHand pasteBuffer printString.
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') -----
+ chooseClickTarget
+ Cursor crossHair showWhile:
+ [Sensor waitButton].
+ Cursor down showWhile:
+ [Sensor anyButtonPressed].
+ ^ (self morphsAt: Sensor cursorPoint) first!
Item was added:
+ ----- Method: PasteUpMorph>>cleanseStepList (in category 'stepping') -----
+ cleanseStepList
+ "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world."
+
+ worldState cleanseStepListForWorld: self!
Item was added:
+ ----- Method: PasteUpMorph>>clearCommandHistory (in category 'undo') -----
+ clearCommandHistory
+
+ worldState ifNotNil: [worldState clearCommandHistory]!
Item was added:
+ ----- Method: PasteUpMorph>>closeUnchangedWindows (in category 'world menu') -----
+ closeUnchangedWindows
+ "Present a menu of window titles for all windows with changes,
+ and activate the one that gets chosen."
+ (UIManager default confirm:
+ 'Do you really want to close all windows
+ except those with unaccepted edits?' translated)
+ ifFalse: [^ self].
+
+ (SystemWindow windowsIn: self satisfying: [:w | w model canDiscardEdits])
+ do: [:w | w delete]!
Item was added:
+ ----- Method: PasteUpMorph>>closedViewerFlapTabs (in category 'misc') -----
+ closedViewerFlapTabs
+ "Answer all the viewer flap tabs in receiver that are closed"
+
+ ^ self submorphs select:
+ [:m | (m isKindOf: ViewerFlapTab) and: [m flapShowing not]]!
Item was added:
+ ----- Method: PasteUpMorph>>collapseAll (in category 'world menu') -----
+ collapseAll
+ "Collapse all windows"
+ (SystemWindow windowsIn: self satisfying: [:w | w isCollapsed not])
+ reverseDo: [:w | w collapseOrExpand. self displayWorld].
+ self collapseNonWindows!
Item was added:
+ ----- Method: PasteUpMorph>>collapseNonWindows (in category 'world menu') -----
+ collapseNonWindows
+ self allNonFlapRelatedSubmorphs do:
+ [:m | m collapse]!
Item was added:
+ ----- Method: PasteUpMorph>>colorAt:belowMorph: (in category 'world state') -----
+ colorAt: aPoint belowMorph: aMorph
+ "Return the color of the pixel immediately behind the given morph at the given point.
+ NOTE: due to some bounds wobble in flexing, we take the middle of 3x3 rect."
+ ^ (self patchAt: (aPoint-1 extent: 3) without: aMorph andNothingAbove: true)
+ colorAt: 1 at 1
+ !
Item was added:
+ ----- Method: PasteUpMorph>>commandHistory (in category 'undo') -----
+ commandHistory
+ "Return the command history for the receiver"
+ ^self isWorldMorph
+ ifTrue:[worldState commandHistory]
+ ifFalse:[super commandHistory]!
Item was added:
+ ----- Method: PasteUpMorph>>commandKeySelectors (in category 'world menu') -----
+ commandKeySelectors
+ "Answer my command-key table"
+
+ | aDict |
+ aDict := self valueOfProperty: #commandKeySelectors ifAbsentPut: [self initializeDesktopCommandKeySelectors].
+ ^ aDict!
Item was added:
+ ----- Method: PasteUpMorph>>connectRemoteUser (in category 'world menu') -----
+ connectRemoteUser
+
+ ^self
+ connectRemoteUserWithName: nil
+ picture: nil
+ andIPAddress: nil
+ !
Item was added:
+ ----- Method: PasteUpMorph>>connectRemoteUserWithName:picture:andIPAddress: (in category 'world menu') -----
+ connectRemoteUserWithName: nameStringOrNil picture: aFormOrNil andIPAddress: aStringOrNil
+ "Prompt for the initials to be used to identify the cursor of a remote user, then create a cursor for that user and wait for a connection."
+
+ | initials addr h |
+ initials := nameStringOrNil.
+ initials isEmptyOrNil ifTrue: [
+ initials := UIManager default request: 'Enter initials for remote user''s cursor?'.
+ ].
+ initials isEmpty ifTrue: [^ self]. "abort"
+ addr := 0.
+ aStringOrNil isEmptyOrNil ifFalse: [
+ addr := NetNameResolver addressForName: aStringOrNil timeout: 30
+ ].
+ addr = 0 ifTrue: [
+ addr := NetNameResolver promptUserForHostAddress.
+ ].
+ addr = 0 ifTrue: [^ self]. "abort"
+
+ (RemoteHandMorph ensureNetworkConnected) ifFalse: [^ self]. "abort"
+
+ h := RemoteHandMorph new userInitials: initials andPicture: aFormOrNil.
+ self addHand: h.
+ h changed.
+ h startListening.
+ h startTransmittingEventsTo: addr.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>convertAlignment (in category 'layout') -----
+ convertAlignment
+ self
+ clipSubmorphs: true ;
+ layoutPolicy: nil ;
+ layoutInset: 0 ;
+ cellInset: 0 ;
+ vResizing: #rigid!
Item was added:
+ ----- Method: PasteUpMorph>>convertRemoteClientToBuffered: (in category 'Nebraska') -----
+ convertRemoteClientToBuffered: aClient
+
+ worldState removeRemoteCanvas: aClient canvas.
+ aClient convertToBuffered.
+ worldState addRemoteCanvas: aClient canvas.
+ self changed. "force a redraw"
+ !
Item was added:
+ ----- Method: PasteUpMorph>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ "transition from project to worldState (8/16/1999)"
+ worldState ifNil: [varDict at: 'project' ifPresent: [ :x | worldState := x]].
+
+ "elimination of specific gradient stuff (5/6/2000)"
+ varDict at: 'fillColor2' ifPresent: [ :color2 |
+ (color isColor and: [color2 isColor and: [color ~= color2]]) ifTrue: [
+ self useGradientFill.
+ self fillStyle
+ colorRamp: {0.0 -> color. 1.0 -> color2};
+ radial: false;
+ origin: self position;
+ direction: ((varDict at: 'gradientDirection') == #vertical
+ ifTrue:[0 at self height]
+ ifFalse:[self width at 0]).
+ ]
+ ].
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') -----
+ correspondingFlapTab
+ "If there is a flap tab whose referent is me, return it, else return nil"
+ self currentWorld flapTabs do:
+ [:aTab | aTab referent == self ifTrue: [^ aTab]].
+ ^ nil!
Item was added:
+ ----- Method: PasteUpMorph>>createCustomModel (in category 'model') -----
+ createCustomModel
+ "Create a model object for this world if it does not yet have one. A model object is an initially empty subclass of MorphicModel. As the user names parts and adds behavior, instance variables and methods are added to this class."
+
+ model isNil ifFalse: [^self].
+ model := MorphicModel newSubclass new!
Item was added:
+ ----- Method: PasteUpMorph>>currentlyUsingVectorVocabulary (in category 'menu & halo') -----
+ currentlyUsingVectorVocabulary
+ "Answer whether this world is currently set up to use the vector vocabulary"
+
+ ^ (self valueOfProperty: #currentVocabularySymbol) == #Vector!
Item was added:
+ ----- Method: PasteUpMorph>>cursor (in category 'e-toy support') -----
+ cursor
+ ^ cursor
+ !
Item was added:
+ ----- Method: PasteUpMorph>>cursor: (in category 'e-toy support') -----
+ cursor: aNumber
+ "for backward compatibility"
+
+ self cursorWrapped: aNumber!
Item was added:
+ ----- Method: PasteUpMorph>>cursorWrapped: (in category 'cursor') -----
+ cursorWrapped: aNumber
+ "Set the cursor to the given number, modulo the number of items I
+ contain. Fractional cursor values are allowed."
+ | oldRect newRect offset |
+ cursor = aNumber
+ ifTrue: [^ self].
+ self hasSubmorphs
+ ifFalse: [cursor := 1.
+ ^ self].
+ oldRect := self selectedRect.
+ offset := (self asNumber: aNumber) - 1 \\ submorphs size.
+ cursor := offset + 1.
+ newRect := self selectedRect.
+ self indicateCursor
+ ifTrue: [self invalidRect: oldRect;
+ invalidRect: newRect]!
Item was added:
+ ----- Method: PasteUpMorph>>deEmphasizeViewMVC: (in category 'world state') -----
+ deEmphasizeViewMVC: asTwoTone
+ self flag: #arNote. "Probably unnecessary"
+ worldState handsDo: "free dependents links if any"
+ [:h | h releaseKeyboardFocus].
+ worldState canvas: nil. "free model's canvas to save space"
+ self fullReleaseCachedState.
+ asTwoTone ifTrue: [
+ "draw deEmphasized as a two-tone (monochrome) form"
+ self displayWorldAsTwoTone].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ Color
+ r: 0.861
+ g: 1.0
+ b: 0.722!
Item was added:
+ ----- Method: PasteUpMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 1!
Item was added:
+ ----- Method: PasteUpMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Preferences defaultWorldColor muchLighter.!
Item was added:
+ ----- Method: PasteUpMorph>>defaultNameStemForInstances (in category 'viewer') -----
+ defaultNameStemForInstances
+ "Answer a basis for names of default instances of the receiver"
+ ^ self isWorldMorph
+ ifFalse:
+ [super defaultNameStemForInstances]
+ ifTrue:
+ ['world']!
Item was added:
+ ----- Method: PasteUpMorph>>defersHaloOnClickTo: (in category 'halos and balloon help') -----
+ defersHaloOnClickTo: aSubMorph
+ "If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"
+ ^ true
+ !
Item was added:
+ ----- Method: PasteUpMorph>>defineApplicationView (in category 'menu & halo') -----
+ defineApplicationView
+
+ | r |
+ r := Rectangle fromUser.
+ self
+ setProperty: #applicationViewBounds
+ toValue: ((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated !
Item was added:
+ ----- Method: PasteUpMorph>>defineFactoryView (in category 'menu & halo') -----
+ defineFactoryView
+
+ | r |
+ r := Rectangle fromUser.
+ self
+ setProperty: #factoryViewBounds
+ toValue: ((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated !
Item was added:
+ ----- Method: PasteUpMorph>>delayedInvokeWorldMenu: (in category 'world menu') -----
+ delayedInvokeWorldMenu: evt
+ self
+ addAlarm: #invokeWorldMenu:
+ with: evt
+ after: 200!
Item was added:
+ ----- Method: PasteUpMorph>>deleteAllHalos (in category 'world state') -----
+ deleteAllHalos
+ self haloMorphs do:
+ [ : m | m target isSelectionMorph ifTrue: [ m target delete ] ].
+ self hands do:
+ [ : each | each removeHalo ]!
Item was added:
+ ----- Method: PasteUpMorph>>deleteBalloonTarget: (in category 'menu & halo') -----
+ deleteBalloonTarget: aMorph
+ "Delete the balloon help targeting the given morph"
+ self handsDo:[:h| h deleteBalloonTarget: aMorph].!
Item was added:
+ ----- Method: PasteUpMorph>>deleteGlobalFlapArtifacts (in category 'flaps') -----
+ deleteGlobalFlapArtifacts
+ "Delete all flap-related detritus from the world"
+
+ | localFlaps |
+ localFlaps := self localFlapTabs collect: [:m | m referent].
+ self submorphs do:
+ [:m |
+ ((m isFlapTab) and: [m isGlobalFlap]) ifTrue: [m delete].
+ m isFlap ifTrue:[(localFlaps includes: m) ifFalse: [m delete]]]
+
+ "ActiveWorld deleteGlobalFlapArtifacts"
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>deleteNonWindows (in category 'world menu') -----
+ deleteNonWindows
+ (UIManager default confirm:
+ 'Do you really want to discard all objects
+ that are not in windows?' translated)
+ ifFalse: [^ self].
+
+ self allNonFlapRelatedSubmorphs do:
+ [:m | m delete]!
Item was added:
+ ----- Method: PasteUpMorph>>detachableScriptingSpace (in category 'world menu') -----
+ detachableScriptingSpace
+ ScriptingSystem newScriptingSpace openInWorld: self!
Item was added:
+ ----- Method: PasteUpMorph>>disconnectAllRemoteUsers (in category 'world menu') -----
+ disconnectAllRemoteUsers
+ "Disconnect all remote hands and stop transmitting events."
+ self world handsDo: [:h |
+ (h isKindOf: RemoteHandMorph)
+ ifTrue: [h withdrawFromWorld]].!
Item was added:
+ ----- Method: PasteUpMorph>>disconnectRemoteUser (in category 'world menu') -----
+ disconnectRemoteUser
+ "Prompt for the initials of the remote user, then remove the remote hand with those initials, breaking its connection."
+
+ "select hand to remove"
+ | initials handToRemove |
+ initials := UIManager default request: 'Enter initials for remote user''s cursor?'.
+ initials isEmpty ifTrue: [^ self]. "abort"
+ handToRemove := nil.
+ self handsDo: [:h |
+ h userInitials = initials ifTrue: [handToRemove := h]].
+ handToRemove ifNil: [^ self]. "no hand with those initials"
+ handToRemove withdrawFromWorld.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>dispatchCommandKeyInWorld:event: (in category 'world menu') -----
+ dispatchCommandKeyInWorld: aChar event: evt
+ "Dispatch the desktop command key if possible. Answer whether handled"
+
+ | aMessageSend |
+ aMessageSend := self commandKeySelectors at: aChar ifAbsent: [^ false].
+ aMessageSend selector numArgs = 0
+ ifTrue:
+ [aMessageSend value]
+ ifFalse:
+ [aMessageSend valueWithArguments: (Array with: evt)].
+ ^ true
+ !
Item was added:
+ ----- Method: PasteUpMorph>>displayWorld (in category 'world state') -----
+ displayWorld
+
+ self outermostWorldMorph privateOuterDisplayWorld
+ !
Item was added:
+ ----- Method: PasteUpMorph>>displayWorldAsTwoTone (in category 'world state') -----
+ displayWorldAsTwoTone
+ "Display the world in living black-and-white. (This is typically done to save space.)"
+
+ worldState displayWorldAsTwoTone: self submorphs: submorphs color: color
+ !
Item was added:
+ ----- Method: PasteUpMorph>>displayWorldNonIncrementally (in category 'world state') -----
+ displayWorldNonIncrementally
+ "Display the morph world non-incrementally. Used for testing."
+
+ (worldState canvas isNil or:
+ [worldState canvas extent ~= self viewBox extent
+ or: [worldState canvas form depth ~= Display depth]])
+ ifTrue:
+ ["allocate a new offscreen canvas the size of the window"
+
+ worldState
+ canvas: (Display defaultCanvasClass extent: self viewBox extent)].
+ worldState canvas fillColor: color.
+ submorphs reverseDo: [:m | worldState canvas fullDrawMorph: m].
+ worldState handsReverseDo: [:h | worldState canvas fullDrawMorph: h].
+ worldState canvas form displayOn: Display at: self viewBox origin.
+ self fullRepaintNeeded. "don't collect damage"
+ Display forceDisplayUpdate!
Item was added:
+ ----- Method: PasteUpMorph>>displayWorldSafely (in category 'world state') -----
+ displayWorldSafely
+
+ worldState displayWorldSafely: self.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>doOneCycle (in category 'world state') -----
+ doOneCycle
+ "see the comment in doOneCycleFor:"
+
+ worldState doOneCycleFor: self!
Item was added:
+ ----- Method: PasteUpMorph>>doOneCycleInBackground (in category 'world state') -----
+ doOneCycleInBackground
+
+ worldState doOneCycleInBackground
+ !
Item was added:
+ ----- Method: PasteUpMorph>>doOneCycleNow (in category 'interaction loop') -----
+ doOneCycleNow
+ "see the comment in doOneCycleNowFor:"
+ worldState doOneCycleNowFor: self.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>doOneSubCycle (in category 'world state') -----
+ doOneSubCycle
+ "Like doOneCycle, but preserves activeHand."
+
+ worldState doOneSubCycleFor: self!
Item was added:
+ ----- Method: PasteUpMorph>>dragThroughOnDesktop: (in category 'world state') -----
+ dragThroughOnDesktop: evt
+ "Draw out a selection rectangle"
+ | selection |
+ selection := SelectionMorph newBounds: (evt cursorPoint extent: 8 at 8).
+ self addMorph: selection.
+ ^ selection extendByHand: evt hand
+ !
Item was added:
+ ----- Method: PasteUpMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Draw in order:
+ - background color
+ - grid, if any
+ - background sketch, if any
+ - Update and draw the turtleTrails form. See the comment in updateTrailsForm.
+ - cursor box if any
+
+ Later (in drawSubmorphsOn:) I will skip drawing the background sketch."
+
+ "draw background fill"
+ super drawOn: aCanvas.
+
+ "draw grid"
+ (self griddingOn and: [self gridVisible])
+ ifTrue:
+ [aCanvas fillRectangle: self bounds
+ fillStyle: (self
+ gridFormOrigin: self gridOrigin
+ grid: self gridModulus
+ background: nil
+ line: Color lightGray)].
+
+ "draw background sketch."
+ backgroundMorph ifNotNil: [
+ self clipSubmorphs ifTrue: [
+ aCanvas clipBy: self clippingBounds
+ during: [ :canvas | canvas fullDrawMorph: backgroundMorph ]]
+ ifFalse: [ aCanvas fullDrawMorph: backgroundMorph ]].
+
+ "draw turtle trails"
+ (lastTurtlePositions isNil or: [lastTurtlePositions isEmpty]) ifFalse:[
+ self updateTrailsForm.
+ ].
+ turtleTrailsForm
+ ifNotNil: [aCanvas paintImage: turtleTrailsForm at: self position].
+
+ "draw cursor"
+ (submorphs notEmpty and: [self indicateCursor])
+ ifTrue:
+ [aCanvas
+ frameRectangle: self selectedRect
+ width: 2
+ color: Color black]!
Item was added:
+ ----- Method: PasteUpMorph>>drawSubmorphsOn: (in category 'painting') -----
+ drawSubmorphsOn: aCanvas
+ "Display submorphs back to front, but skip my background sketch."
+
+ | drawBlock |
+ submorphs isEmpty ifTrue: [^self].
+ drawBlock := [:canvas | submorphs reverseDo: [:m | m ~~ backgroundMorph ifTrue: [ canvas fullDrawMorph: m ]]].
+ self clipSubmorphs
+ ifTrue: [aCanvas clipBy: self clippingBounds during: drawBlock]
+ ifFalse: [drawBlock value: aCanvas]!
Item was added:
+ ----- Method: PasteUpMorph>>drawingClass (in category 'world menu') -----
+ drawingClass
+
+ ^ SketchMorph!
Item was added:
+ ----- Method: PasteUpMorph>>dropEnabled (in category 'dropping/grabbing') -----
+ dropEnabled
+ "Get this morph's ability to add and remove morphs via drag-n-drop."
+
+ ^ (self valueOfProperty: #dropEnabled) ~~ false
+ !
Item was added:
+ ----- Method: PasteUpMorph>>dropFiles: (in category 'event handling') -----
+ dropFiles: anEvent
+ "Handle a number of dropped files from the OS.
+ TODO:
+ - use a more general mechanism for figuring out what to do with the file (perhaps even offering a choice from a menu)
+ - remember the resource location or (when in browser) even the actual file handle
+ "
+ | numFiles stream handler |
+ numFiles := anEvent contents.
+ 1 to: numFiles do: [ :i |
+ (stream := FileStream requestDropStream: i) ifNotNil: [
+ handler := ExternalDropHandler lookupExternalDropHandler: stream.
+ [ handler ifNotNil: [handler handle: stream in: self dropEvent: anEvent ] ]
+ ensure: [ stream close ] ] ].!
Item was added:
+ ----- Method: PasteUpMorph>>dumpPresenter (in category 'accessing') -----
+ dumpPresenter
+ "Dump my current presenter"
+ presenter := nil.!
Item was added:
+ ----- Method: PasteUpMorph>>embeddedProjectDisplayMode (in category 'world state') -----
+ embeddedProjectDisplayMode
+
+ "#naked - the embedded project/world is just a pasteup in the outer p/w
+ #window - the embedded p/w is in a system window in the outer p/w
+ #frame - the embedded p/w is in a green frame and clipped
+ #scaled - the embedded p/w is in a green frame and scaled to fit"
+
+ ^#scaled
+ !
Item was added:
+ ----- Method: PasteUpMorph>>enableGlobalFlaps (in category 'flaps') -----
+ enableGlobalFlaps
+ "Restore saved global flaps, or obtain brand-new system defaults if necessary"
+
+ Flaps globalFlapTabs. "If nil, creates new ones"
+ self addGlobalFlaps "put them on screen"!
Item was added:
+ ----- Method: PasteUpMorph>>endDrawing: (in category 'world state') -----
+ endDrawing: evt
+ "If painting is already underway
+ in the receiver, finish and save it."
+ | editor |
+ (editor := self sketchEditorOrNil) ifNotNil:[
+ editor save: evt.
+ Cursor normal show.
+ ].!
Item was added:
+ ----- Method: PasteUpMorph>>exit (in category 'world state') -----
+ exit
+
+ Project current exit
+ !
Item was added:
+ ----- Method: PasteUpMorph>>expandAll (in category 'world menu') -----
+ expandAll
+ "Expand all windows"
+ (SystemWindow windowsIn: self satisfying: [:w | w isCollapsed])
+ reverseDo: [:w | w collapseOrExpand. self displayWorld]!
Item was added:
+ ----- Method: PasteUpMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+
+ super extent: aPoint.
+ worldState ifNotNil: [
+ worldState viewBox ifNotNil: [
+ worldState canvas: nil.
+ worldState viewBox: bounds
+ ].
+ ].!
Item was added:
+ ----- Method: PasteUpMorph>>extractScreenRegion:andPutSketchInHand: (in category 'world menu') -----
+ extractScreenRegion: poly andPutSketchInHand: hand
+ "The user has specified a polygonal area of the Display.
+ Now capture the pixels from that region, and put in the hand as a Sketch."
+ | screenForm outline topLeft innerForm exterior |
+ outline := poly shadowForm.
+ topLeft := outline offset.
+ exterior := (outline offset: 0 at 0) anyShapeFill reverse.
+ screenForm := Form fromDisplay: (topLeft extent: outline extent).
+ screenForm eraseShape: exterior.
+ innerForm := screenForm trimBordersOfColor: Color transparent.
+ innerForm isAllWhite ifFalse:
+ [hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was added:
+ ----- Method: PasteUpMorph>>findAChangeSorter: (in category 'world menu') -----
+ findAChangeSorter: evt
+ "Locate a change sorter, open it, and bring it to the front. Create one if necessary"
+
+ self findAWindowSatisfying:
+ [:aWindow | (aWindow model isMemberOf: ChangeSorter) or:
+ [aWindow model isKindOf: DualChangeSorter]] orMakeOneUsing: [DualChangeSorter open]!
Item was added:
+ ----- Method: PasteUpMorph>>findAFileList: (in category 'world menu') -----
+ findAFileList: evt
+ "Bring a file list to the foreground, reusing an existing one if possible."
+ self
+ findAWindowSatisfying: [ : aWindow | (aWindow model class = FileList) and: [ aWindow model hasUnacceptedEdits not ] ]
+ orMakeOneUsing: [ FileList prototypicalToolWindow openInWorld ]!
Item was added:
+ ----- Method: PasteUpMorph>>findAMessageNamesWindow: (in category 'world menu') -----
+ findAMessageNamesWindow: evt
+ "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary"
+
+ self findAWindowSatisfying:
+ [:aWindow | aWindow model isKindOf: MessageNames] orMakeOneUsing: [MessageNames openMessageNames]!
Item was added:
+ ----- Method: PasteUpMorph>>findAPreferencesPanel: (in category 'world menu') -----
+ findAPreferencesPanel: evt
+ "Locate a Preferences Panel, open it, and bring it to the front. Create one if necessary"
+ Smalltalk at: #PreferenceBrowser ifPresent:[:pb|
+ self findAWindowSatisfying:[:aWindow | aWindow model isKindOf: pb]
+ orMakeOneUsing:[pb open]
+ ].!
Item was added:
+ ----- Method: PasteUpMorph>>findATranscript: (in category 'world menu') -----
+ findATranscript: evt
+ "Locate a transcript, open it, and bring it to the front. Create one if necessary"
+
+ self findAWindowSatisfying:
+ [:aWindow | aWindow model == Transcript] orMakeOneUsing: [Transcript openLabel: 'Transcript']!
Item was added:
+ ----- Method: PasteUpMorph>>findAWindowSatisfying:orMakeOneUsing: (in category 'world menu') -----
+ findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock
+ "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock"
+
+ submorphs do:
+ [:aMorph | | aWindow |
+ (((aWindow := aMorph renderedMorph) isSystemWindow)
+ and: [qualifyingBlock value: aWindow]) ifTrue:
+ [aWindow isCollapsed ifTrue: [aWindow expand].
+ self addMorphFront: aWindow.
+ aWindow activateAndForceLabelToShow.
+ ^self]].
+ "None found, so create one"
+ makeBlock value!
Item was added:
+ ----- Method: PasteUpMorph>>findDirtyBrowsers: (in category 'world menu') -----
+ findDirtyBrowsers: evt
+ "Present a menu of window titles for browsers with changes,
+ and activate the one that gets chosen."
+
+ | menu |
+ menu := MenuMorph new.
+ (SystemWindow windowsIn: self
+ satisfying: [:w | (w model isKindOf: Browser) and: [w model canDiscardEdits not]])
+ do:
+ [:w |
+ menu
+ add: w label
+ target: w
+ action: #activate].
+ menu submorphs notEmpty ifTrue: [menu popUpEvent: evt in: self]!
Item was added:
+ ----- Method: PasteUpMorph>>findDirtyWindows: (in category 'world menu') -----
+ findDirtyWindows: evt
+ "Present a menu of window titles for all windows with changes,
+ and activate the one that gets chosen."
+
+ | menu |
+ menu := MenuMorph new.
+ (SystemWindow windowsIn: self
+ satisfying: [:w | w model canDiscardEdits not]) do:
+ [:w |
+ menu
+ add: w label
+ target: w
+ action: #activate].
+ menu submorphs notEmpty ifTrue: [menu popUpEvent: evt in: self]!
Item was added:
+ ----- Method: PasteUpMorph>>findWindow: (in category 'world menu') -----
+ findWindow: evt
+ "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo."
+ | menu expanded collapsed nakedMorphs |
+ menu := MenuMorph new.
+ expanded := SystemWindow windowsIn: self satisfying: [:w | w isCollapsed not].
+ collapsed := SystemWindow windowsIn: self satisfying: [:w | w isCollapsed].
+ nakedMorphs := self submorphsSatisfying:
+ [:m | (m isSystemWindow not and: [(m isStickySketchMorph) not]) and:
+ [(m isFlapTab) not]].
+ (expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty)) ifTrue: [^ Beeper beep].
+ (expanded asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do:
+ [:w | menu add: w label target: w action: #activateAndForceLabelToShow.
+ w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
+ (expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty)) ifFalse: [menu addLine].
+ (collapsed asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do:
+ [:w | menu add: w label target: w action: #collapseOrExpand.
+ w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
+ nakedMorphs isEmpty ifFalse: [menu addLine].
+ (nakedMorphs asSortedCollection: [:w1 :w2 | w1 nameForFindWindowFeature caseInsensitiveLessOrEqual: w2 nameForFindWindowFeature]) do:
+ [:w | menu add: w nameForFindWindowFeature target: w action: #comeToFrontAndAddHalo].
+ menu addTitle: 'find window' translated.
+
+ menu popUpEvent: evt in: self.!
Item was added:
+ ----- Method: PasteUpMorph>>firstHand (in category 'project state') -----
+ firstHand
+
+ ^ worldState hands first!
Item was added:
+ ----- Method: PasteUpMorph>>fixUponLoad:seg: (in category 'objects from disk') -----
+ fixUponLoad: aProject seg: anImageSegment
+ "We are in an old project that is being loaded from disk.
+ Fix up conventions that have changed."
+
+ self isWorldMorph ifTrue: [
+ (self valueOfProperty: #soundAdditions) ifNotNil:
+ [:additions | SampledSound
+ assimilateSoundsFrom: additions]].
+
+ ^ super fixUponLoad: aProject seg: anImageSegment!
Item was added:
+ ----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
+ flapTab
+ | ww |
+ self isFlap ifFalse:[^nil].
+ ww := self world ifNil: [World].
+ ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]!
Item was added:
+ ----- Method: PasteUpMorph>>flapTabs (in category 'flaps') -----
+ flapTabs
+ ^ self submorphs select:[:m| m isFlapTab]!
Item was added:
+ ----- Method: PasteUpMorph>>flashRects:color: (in category 'world state') -----
+ flashRects: rectangleList color: aColor
+ "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work."
+ "Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode."
+
+ | blt |
+ blt := (BitBlt toForm: Display)
+ sourceForm: nil;
+ sourceOrigin: 0 at 0;
+ clipRect: self viewBox;
+ combinationRule: Form reverse.
+ rectangleList do: [:r | | screenRect |
+ screenRect := r translateBy: self viewBox origin.
+ blt destRect: screenRect; copyBits.
+ Display forceToScreen: screenRect; forceDisplayUpdate.
+ (Delay forMilliseconds: 15) wait.
+ blt destRect: screenRect; copyBits.
+ Display forceToScreen: screenRect; forceDisplayUpdate].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>fullContainsPoint: (in category 'geometry testing') -----
+ fullContainsPoint: pt
+ "The world clips its children"
+
+ worldState ifNil: [^super fullContainsPoint: pt].
+ ^bounds containsPoint: pt
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>fullRepaintNeeded (in category 'world state') -----
+ fullRepaintNeeded
+
+ worldState doFullRepaint.
+ SystemWindow windowsIn: self
+ satisfying: [:w | w makeMeVisible. false].
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>getWorldMenu: (in category 'world menu') -----
+ getWorldMenu: aSymbol
+ ^(TheWorldMenu new
+ world: self
+ project: (self project ifNil: [Project current]) "mvc??"
+ hand: self primaryHand) perform: aSymbol!
Item was added:
+ ----- Method: PasteUpMorph>>goBack (in category 'world state') -----
+ goBack
+
+ Project returnToPreviousProject.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>grabDrawingFromScreen: (in category 'world menu') -----
+ grabDrawingFromScreen: evt
+ "Allow the user to specify a rectangular area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand."
+ | m |
+ m := self drawingClass new form: Form fromUser.
+ evt hand position: Sensor cursorPoint. "update hand pos after Sensor loop in fromUser"
+ evt hand attachMorph: m.!
Item was added:
+ ----- Method: PasteUpMorph>>grabFloodFromScreen: (in category 'world menu') -----
+ grabFloodFromScreen: evt
+ "Allow the user to plant a flood seed on the Display, and create a new drawing morph from the resulting region. Attach the result to the hand."
+ | screenForm exterior p1 box |
+ p1 := Cursor crossHair showWhile: [Sensor waitButton].
+ box := Display floodFill: Color transparent at: p1.
+ exterior := ((Display copy: box) makeBWForm: Color transparent) reverse.
+ self world invalidRect: box; displayWorldSafely.
+ (box area > (Display boundingBox area // 2))
+ ifTrue: [^ UIManager default notify: 'Sorry, the region was too big'].
+ (exterior deepCopy reverse anyShapeFill reverse) "save interior bits"
+ displayOn: exterior at: 0 at 0 rule: Form and.
+ screenForm := Form fromDisplay: box.
+ screenForm eraseShape: exterior.
+ screenForm isAllWhite ifFalse:
+ [evt hand attachMorph: (self drawingClass withForm: screenForm)]!
Item was added:
+ ----- Method: PasteUpMorph>>grabLassoFromScreen: (in category 'world menu') -----
+ grabLassoFromScreen: evt
+ "Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand."
+
+ self extractScreenRegion: (PolygonMorph fromHandFreehand: evt hand)
+ andPutSketchInHand: evt hand
+ !
Item was added:
+ ----- Method: PasteUpMorph>>grabRubberBandFromScreen: (in category 'world menu') -----
+ grabRubberBandFromScreen: evt
+ "Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand."
+
+ self extractScreenRegion: (PolygonMorph fromHand: evt hand)
+ andPutSketchInHand: evt hand!
Item was added:
+ ----- Method: PasteUpMorph>>gradientFillColor: (in category 'display') -----
+ gradientFillColor: aColor
+ "For backwards compatibility with GradientFillMorph"
+
+ self flag: #fixThis.
+ self useGradientFill.
+ self fillStyle colorRamp: {0.0 -> self fillStyle colorRamp first value. 1.0 -> aColor}.
+ self changed!
Item was added:
+ ----- Method: PasteUpMorph>>gridModulus (in category 'gridding') -----
+ gridModulus
+
+ ^ self gridSpec extent!
Item was added:
+ ----- Method: PasteUpMorph>>gridModulus: (in category 'gridding') -----
+ gridModulus: newModulus
+
+ self gridSpecPut: (self gridOrigin extent: newModulus).
+ self changed!
Item was added:
+ ----- Method: PasteUpMorph>>gridOrigin (in category 'gridding') -----
+ gridOrigin
+
+ ^ self gridSpec origin!
Item was added:
+ ----- Method: PasteUpMorph>>gridOrigin: (in category 'gridding') -----
+ gridOrigin: newOrigin
+
+ ^ self gridSpecPut: (newOrigin extent: self gridModulus)!
Item was added:
+ ----- Method: PasteUpMorph>>gridPoint: (in category 'geometry') -----
+ gridPoint: ungriddedPoint
+
+ self griddingOn ifFalse: [^ ungriddedPoint].
+ ^ (ungriddedPoint - self position - self gridOrigin grid: self gridModulus)
+ + self position + self gridOrigin!
Item was added:
+ ----- Method: PasteUpMorph>>gridSpec (in category 'gridding') -----
+ gridSpec
+ "Gridding rectangle provides origin and modulus"
+
+ ^ self valueOfProperty: #gridSpec ifAbsent: [0 at 0 extent: 8 at 8]!
Item was added:
+ ----- Method: PasteUpMorph>>gridSpecPut: (in category 'gridding') -----
+ gridSpecPut: newSpec
+ "Gridding rectangle provides origin and modulus"
+
+ ^ self setProperty: #gridSpec toValue: newSpec!
Item was added:
+ ----- Method: PasteUpMorph>>gridVisible (in category 'gridding') -----
+ gridVisible
+
+ ^ self hasProperty: #gridVisible!
Item was added:
+ ----- Method: PasteUpMorph>>gridVisibleOnOff (in category 'gridding') -----
+ gridVisibleOnOff
+
+ self setProperty: #gridVisible toValue: self gridVisible not.
+ self changed!
Item was added:
+ ----- Method: PasteUpMorph>>gridVisibleString (in category 'gridding') -----
+ gridVisibleString
+ "Answer a string to be used in a menu offering the opportunity
+ to show or hide the grid"
+ ^ (self gridVisible
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ , 'show grid when gridding' translated!
Item was added:
+ ----- Method: PasteUpMorph>>griddingOn (in category 'gridding') -----
+ griddingOn
+
+ ^ griddingOn ifNil: [false]!
Item was added:
+ ----- Method: PasteUpMorph>>griddingOnOff (in category 'gridding') -----
+ griddingOnOff
+
+ griddingOn := self griddingOn not.
+ self changed!
Item was added:
+ ----- Method: PasteUpMorph>>griddingString (in category 'gridding') -----
+ griddingString
+ "Answer a string to use in a menu offering the user the
+ opportunity to start or stop using gridding"
+ ^ (self griddingOn
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ , 'use gridding' translated!
Item was added:
+ ----- Method: PasteUpMorph>>haloMorphs (in category 'world state') -----
+ haloMorphs
+ ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]!
Item was added:
+ ----- Method: PasteUpMorph>>handleFatalDrawingError: (in category 'world state') -----
+ handleFatalDrawingError: errMsg
+ "Handle a fatal drawing error."
+ self flag: #toRemove. "Implementation moved to Project, but are there external packages with senders?"
+ Project current handleFatalDrawingError: errMsg
+ !
Item was added:
+ ----- Method: PasteUpMorph>>handlesKeyboard: (in category 'event handling') -----
+ handlesKeyboard: evt
+ ^self isWorldMorph or:[evt keyCharacter == Character tab and:[self tabAmongFields]]!
Item was added:
+ ----- Method: PasteUpMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ ^true!
Item was added:
+ ----- Method: PasteUpMorph>>hands (in category 'project state') -----
+ hands
+
+ ^ worldState hands!
Item was added:
+ ----- Method: PasteUpMorph>>handsDo: (in category 'project state') -----
+ handsDo: aBlock
+
+ ^ worldState ifNotNil: [ worldState handsDo: aBlock ]!
Item was added:
+ ----- Method: PasteUpMorph>>handsReverseDo: (in category 'project state') -----
+ handsReverseDo: aBlock
+
+ ^ worldState ifNotNil: [ worldState handsReverseDo: aBlock ]!
Item was added:
+ ----- Method: PasteUpMorph>>hasRemoteServer (in category 'Nebraska') -----
+ hasRemoteServer
+ ^self remoteServer notNil!
Item was added:
+ ----- Method: PasteUpMorph>>hasTransferMorphConverter (in category 'dropping/grabbing') -----
+ hasTransferMorphConverter
+ ^ self transferMorphConverter ~= #yourself!
Item was added:
+ ----- Method: PasteUpMorph>>heightForThumbnails (in category 'misc') -----
+ heightForThumbnails
+ ^ self valueOfProperty: #heightForThumbnails ifAbsent: [50]!
Item was added:
+ ----- Method: PasteUpMorph>>hideFlapsOtherThan:ifClingingTo: (in category 'misc') -----
+ hideFlapsOtherThan: aFlapTab ifClingingTo: anEdgeSymbol
+ "Hide flaps on the given edge unless they are the given one"
+
+ self flapTabs do:
+ [:aTab | (aTab edgeToAdhereTo == anEdgeSymbol)
+ ifTrue:
+ [aTab == aFlapTab
+ ifFalse:
+ [aTab hideFlap]]]!
Item was added:
+ ----- Method: PasteUpMorph>>hideViewerFlaps (in category 'misc') -----
+ hideViewerFlaps
+ self flapTabs do:[:aTab |
+ (aTab isKindOf: ViewerFlapTab) ifTrue:[aTab hideFlap]]!
Item was added:
+ ----- Method: PasteUpMorph>>hideViewerFlapsOtherThanFor: (in category 'misc') -----
+ hideViewerFlapsOtherThanFor: aPlayer
+ self flapTabs do:
+ [:aTab | (aTab isKindOf: ViewerFlapTab)
+ ifTrue:
+ [aTab scriptedPlayer == aPlayer
+ ifFalse:
+ [aTab hideFlap]]]!
Item was added:
+ ----- Method: PasteUpMorph>>icon (in category 'thumbnail') -----
+ icon
+ "Answer a form with an icon to represent the receiver"
+ ^ self isWorldMorph
+ ifTrue: [MenuIcons homeIcon]
+ ifFalse: [MenuIcons projectIcon]!
Item was added:
+ ----- Method: PasteUpMorph>>indicateCursor (in category 'options') -----
+ indicateCursor
+ ^ indicateCursor == true!
Item was added:
+ ----- Method: PasteUpMorph>>indicateCursor: (in category 'options') -----
+ indicateCursor: aBoolean
+ indicateCursor := aBoolean!
Item was added:
+ ----- Method: PasteUpMorph>>indicateCursorString (in category 'menu & halo') -----
+ indicateCursorString
+ "Answer the string to be shown in a menu to represent the
+ whether-to-indicate-cursor status"
+ ^ (self indicateCursor
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'indicate cursor' translated!
Item was added:
+ ----- Method: PasteUpMorph>>initForProject: (in category 'world state') -----
+ initForProject: aWorldState
+
+ worldState := aWorldState.
+ bounds := Display boundingBox.
+ self color: Preferences defaultWorldColor.
+ self addHand: HandMorph new.
+ self setProperty: #automaticPhraseExpansion toValue: true.
+ self setProperty: #optimumExtentFromAuthor toValue: Display extent.
+ self wantsMouseOverHalos: Preferences mouseOverHalos.
+ self borderWidth: 0.
+ model := nil.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ cursor := 1.
+ padding := 3.
+ self enableDragNDrop.
+ self isWorldMorph
+ ifTrue: [self setProperty: #automaticPhraseExpansion toValue: true].
+ self clipSubmorphs: true!
Item was added:
+ ----- Method: PasteUpMorph>>initializeDesktopCommandKeySelectors (in category 'world menu') -----
+ initializeDesktopCommandKeySelectors
+ "Provide the starting settings for desktop command key selectors. Answer the dictionary."
+
+ "ActiveWorld initializeDesktopCommandKeySelectors"
+ | dict |
+ dict := IdentityDictionary new.
+ self defaultDesktopCommandKeyTriplets do:
+ [:trip | | messageSend |
+ messageSend := MessageSend receiver: trip second selector: trip third.
+ dict at: trip first put: messageSend].
+ self setProperty: #commandKeySelectors toValue: dict.
+ ^ dict
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ "Answer an instance of the receiver suitable for placing in a parts bin for authors"
+
+ self initialize.
+ self color: Color green muchLighter; extent: 100 @ 80; borderColor: (Color r: 0.645 g: 0.935 b: 0.161).
+ self extent: 300 @ 240.
+ self beSticky!
Item was added:
+ ----- Method: PasteUpMorph>>innocuousName (in category 'misc') -----
+ innocuousName
+ ^ (self isFlap)
+ ifTrue:
+ ['flap' translated]
+ ifFalse:
+ [super innocuousName]!
Item was added:
+ ----- Method: PasteUpMorph>>install (in category 'world state') -----
+ install
+ owner := nil. "since we may have been inside another world previously"
+ ActiveWorld := self.
+ ActiveHand := self hands first. "default"
+ ActiveEvent := nil.
+ submorphs do: [:ss | ss owner isNil ifTrue: [ss privateOwner: self]].
+ "Transcript that was in outPointers and then got deleted."
+ self viewBox: Display boundingBox.
+ Sensor flushAllButDandDEvents.
+ worldState handsDo: [:h | h initForEvents].
+ self installFlaps.
+ self borderWidth: 0. "default"
+ (Preferences showSecurityStatus
+ and: [SecurityManager default isInRestrictedMode])
+ ifTrue:
+ [self
+ borderWidth: 2;
+ borderColor: Color red].
+ self presenter allExtantPlayers do: [:player | player prepareToBeRunning].
+ SystemWindow noteTopWindowIn: self.
+ self displayWorldSafely!
Item was added:
+ ----- Method: PasteUpMorph>>installFlaps (in category 'world state') -----
+ installFlaps
+ "Get flaps installed within the bounds of the receiver"
+
+ Project current assureFlapIntegrity.
+ self addGlobalFlaps.
+ self localFlapTabs do:
+ [:aFlapTab | aFlapTab adaptToWorld].
+ self assureFlapTabsFitOnScreen.
+ self bringTopmostsToFront!
Item was added:
+ ----- Method: PasteUpMorph>>invalidRect:from: (in category 'change reporting') -----
+ invalidRect: damageRect from: aMorph
+ "Clip damage reports to my bounds, since drawing is clipped to my bounds."
+ self isWorldMorph
+ ifTrue: [worldState recordDamagedRect: damageRect].
+ ^super invalidRect: damageRect from: aMorph!
Item was added:
+ ----- Method: PasteUpMorph>>invokeWorldMenu: (in category 'world menu') -----
+ invokeWorldMenu: evt
+ "Put up the world menu, triggered by the passed-in event. But don't do it if the eToyFriendly preference is set to true."
+
+ Preferences eToyFriendly ifFalse:
+ [self putUpWorldMenu: evt]!
Item was added:
+ ----- Method: PasteUpMorph>>isEasySelecting (in category 'testing') -----
+ isEasySelecting
+ "This is to isolate easySelection predicate.
+ Selectors in holders make no sense so we are limiting easy selection to the worldMorph.
+ It would also make sense in playfield so feel free to adjust this predicate. Selection can always be forced by using the shift before mouse down."
+
+ ^ self isWorldMorph and: [ Preferences easySelection ]!
Item was added:
+ ----- Method: PasteUpMorph>>isOpenForDragNDropString (in category 'menu & halo') -----
+ isOpenForDragNDropString
+ "Answer the string to be shown in a menu to represent the
+ open-to-drag-n-drop status"
+ ^ (self dragNDropEnabled
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'open to drag & drop' translated!
Item was added:
+ ----- Method: PasteUpMorph>>isPartsBin (in category 'parts bin') -----
+ isPartsBin
+ ^ isPartsBin == true!
Item was added:
+ ----- Method: PasteUpMorph>>isPartsBin: (in category 'options') -----
+ isPartsBin: aBoolean
+ isPartsBin := aBoolean!
Item was added:
+ ----- Method: PasteUpMorph>>isPartsBinString (in category 'menu & halo') -----
+ isPartsBinString
+ "Answer the string to be shown in a menu to represent the
+ parts-bin status"
+ ^ (self isPartsBin
+ ifTrue: ['<on>']
+ ifFalse: ['<off>']), 'parts bin' translated!
Item was added:
+ ----- Method: PasteUpMorph>>isPlayfieldLike (in category 'classification') -----
+ isPlayfieldLike
+ ^ true!
Item was added:
+ ----- Method: PasteUpMorph>>isStepping: (in category 'project state') -----
+ isStepping: aMorph
+ ^ worldState isStepping: aMorph!
Item was added:
+ ----- Method: PasteUpMorph>>isStepping:selector: (in category 'project state') -----
+ isStepping: aMorph selector: aSelector
+ ^ worldState isStepping: aMorph selector: aSelector!
Item was added:
+ ----- Method: PasteUpMorph>>isWorldMorph (in category 'classification') -----
+ isWorldMorph
+
+ ^ worldState notNil!
Item was added:
+ ----- Method: PasteUpMorph>>jumpToProject (in category 'world state') -----
+ jumpToProject
+
+ Project current jumpToProject.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: aMorph event: anEvent
+ "This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph"
+
+ super justDroppedInto: aMorph event: anEvent.
+ self isPartsBin ifTrue: [self setPartsBinStatusTo: true] "gets some things right about the subtle case of dropping a parts bin"
+ !
Item was added:
+ ----- Method: PasteUpMorph>>keyStroke: (in category 'event handling') -----
+ keyStroke: anEvent
+ "A keystroke has been made. Service event handlers and, if it's a keystroke presented to the world, dispatch it to #unfocusedKeystroke:"
+
+ | selected |
+ super keyStroke: anEvent. "Give event handlers a chance"
+
+ selected := self selectedObject.
+ selected isNil
+ ifFalse:[ selected moveOrResizeFromKeystroke: anEvent ].
+
+ (anEvent keyCharacter == Character tab) ifTrue:
+ [self tabAmongFields
+ ifTrue:[^ self tabHitWithEvent: anEvent]].
+ self isWorldMorph ifTrue:
+ [self keystrokeInWorld: anEvent]!
Item was added:
+ ----- Method: PasteUpMorph>>keyboardNavigationHandler (in category 'world menu') -----
+ keyboardNavigationHandler
+ "Answer the receiver's existing keyboardNavigationHandler, or nil if none."
+
+ | aHandler |
+ aHandler := self valueOfProperty: #keyboardNavigationHandler ifAbsent: [^ nil].
+ (aHandler hasProperty: #moribund) ifTrue: "got clobbered in another project"
+ [self removeProperty: #keyboardNavigationHander.
+ ^ nil].
+ ^ aHandler!
Item was added:
+ ----- Method: PasteUpMorph>>keyboardNavigationHandler: (in category 'world menu') -----
+ keyboardNavigationHandler: aHandler
+ "Set the receiver's keyboard navigation handler as indicated. A nil argument means to remove the handler"
+
+ aHandler
+ ifNil:
+ [self removeProperty: #keyboardNavigationHandler]
+ ifNotNil:
+ [self setProperty: #keyboardNavigationHandler toValue: aHandler]!
Item was added:
+ ----- Method: PasteUpMorph>>keystrokeInWorld: (in category 'world menu') -----
+ keystrokeInWorld: evt
+ "A keystroke was hit when no keyboard focus was set, so it is sent here to the world instead."
+
+ | aChar isCmd ascii |
+ aChar := evt keyCharacter.
+ (ascii := aChar asciiValue) = 27 ifTrue: "escape key"
+ [^ self putUpWorldMenuFromEscapeKey].
+ (evt controlKeyPressed not
+ and: [(#(1 4 8 28 29 30 31 32) includes: ascii) "home, end, backspace, arrow keys, space"
+ and: [self keyboardNavigationHandler notNil]])
+ ifTrue: [self keyboardNavigationHandler navigateFromKeystroke: aChar].
+
+ isCmd := evt commandKeyPressed and: [Preferences cmdKeysInText].
+ (evt commandKeyPressed and: [Preferences eToyFriendly])
+ ifTrue:
+ [(aChar == $W) ifTrue: [^ self putUpWorldMenu: evt]].
+ (isCmd and: [Preferences honorDesktopCmdKeys]) ifTrue:
+ [^ self dispatchCommandKeyInWorld: aChar event: evt].
+
+ "It was unhandled. Remember the keystroke."
+ self lastKeystroke: evt keyString.
+ self triggerEvent: #keyStroke!
Item was added:
+ ----- Method: PasteUpMorph>>lastKeystroke (in category 'accessing') -----
+ lastKeystroke
+ "Answer the last keystroke fielded by the receiver"
+
+ ^ self valueOfProperty: #lastKeystroke ifAbsent: ['']!
Item was added:
+ ----- Method: PasteUpMorph>>lastKeystroke: (in category 'accessing') -----
+ lastKeystroke: aString
+ "Remember the last keystroke fielded by the receiver"
+
+ ^ self setProperty: #lastKeystroke toValue: aString!
Item was added:
+ ----- Method: PasteUpMorph>>laySubpartsOutInOneRow (in category 'layout') -----
+ laySubpartsOutInOneRow
+ | aPosition |
+ aPosition := 0 @ padding.
+ submorphs do:
+ [:aMorph |
+ aMorph position: (aPosition + (padding @ 0)).
+ aPosition := aMorph topRight]!
Item was added:
+ ----- Method: PasteUpMorph>>layoutChanged (in category 'layout') -----
+ layoutChanged
+ "The receiver's layout changed; inform above and below"
+ super layoutChanged.
+ (self valueOfProperty: #SqueakPage) ifNotNil: [
+ self setProperty: #pageDirty toValue: true].
+ "I am the morph of a SqueakPage, I have changed and
+ need to be written out again"
+ !
Item was added:
+ ----- Method: PasteUpMorph>>listOfSteppingMorphs (in category 'project state') -----
+ listOfSteppingMorphs
+ ^ worldState listOfSteppingMorphs
+
+ "self currentWorld listOfSteppingMorphs"!
Item was added:
+ ----- Method: PasteUpMorph>>localFlapTabs (in category 'flaps') -----
+ localFlapTabs
+ "Answer a list of local flap tabs in the current project"
+
+ | globalList aList |
+ globalList := Flaps globalFlapTabsIfAny.
+ aList := OrderedCollection new.
+ submorphs do:
+ [:m | | aFlapTab |
+ ((m isFlapTab) and: [(globalList includes: m) not])
+ ifTrue:
+ [aList add: m]
+ ifFalse:
+ [((m isFlap) and:
+ [(aFlapTab := m submorphs detect: [:n | n isFlapTab] ifNone: [nil]) notNil])
+ ifTrue:
+ [aList add: aFlapTab]]].
+ ^ aList!
Item was added:
+ ----- Method: PasteUpMorph>>makeNewDrawing: (in category 'world menu') -----
+ makeNewDrawing: evt
+ ^self makeNewDrawing: evt at: evt position!
Item was added:
+ ----- Method: PasteUpMorph>>makeNewDrawing:at: (in category 'world menu') -----
+ makeNewDrawing: evt at: aPoint
+ "make a new drawing, triggered by the given event, with the painting area centered around the given point"
+
+ | w newSketch newPlayer sketchEditor aPalette rect aPaintBox aPaintTab aWorld |
+ w := self world.
+ w assureNotPaintingElse: [^ self].
+ rect := self paintingBoundsAround: aPoint.
+ aPalette := self standardPalette.
+ aPalette ifNotNil: [aPalette showNoPalette; layoutChanged].
+ w prepareToPaint.
+
+ newSketch := self drawingClass new.
+ Smalltalk at: #UnscriptedPlayer ifPresent:[:aClass|
+ newSketch player: (newPlayer := aClass newUserInstance).
+ newPlayer costume: newSketch.
+ ].
+ newSketch nominalForm: (Form extent: rect extent depth: w assuredCanvas depth).
+ newSketch bounds: rect.
+ sketchEditor := SketchEditorMorph new.
+ w addMorphFront: sketchEditor.
+ sketchEditor initializeFor: newSketch inBounds: rect pasteUpMorph: self.
+ sketchEditor
+ afterNewPicDo: [:aForm :aRect | | tfx ownerBeforeHack whereToPresent |
+ whereToPresent := self presenter.
+ newSketch form: aForm.
+ tfx := self transformFrom: w.
+ newSketch position: (tfx globalPointToLocal: aRect origin).
+ newSketch rotationStyle: sketchEditor rotationStyle.
+ newSketch forwardDirection: sketchEditor forwardDirection.
+
+ ownerBeforeHack := newSketch owner. "about to break the invariant!!!!"
+ newSketch privateOwner: self. "temp for halo access"
+ newPlayer ifNotNil:[newPlayer setHeading: sketchEditor forwardDirection].
+ (aPaintTab := (aWorld := self world) paintingFlapTab)
+ ifNotNil:[aPaintTab hideFlap]
+ ifNil:[(aPaintBox := aWorld paintBox) ifNotNil:[aPaintBox delete]].
+
+ "Includes newSketch rotationDegrees: sketchEditor forwardDirection."
+ newSketch privateOwner: ownerBeforeHack. "probably nil, but let's be certain"
+
+ self addMorphFront: (newPlayer ifNil:[newSketch] ifNotNil:[newPlayer costume]).
+ w startSteppingSubmorphsOf: newSketch.
+ whereToPresent drawingJustCompleted: newSketch]
+ ifNoBits:[
+ (aPaintTab := (aWorld := self world) paintingFlapTab)
+ ifNotNil:[aPaintTab hideFlap]
+ ifNil:[(aPaintBox := aWorld paintBox) ifNotNil:[aPaintBox delete]].
+ aPalette ifNotNil: [aPalette showNoPalette].]!
Item was added:
+ ----- Method: PasteUpMorph>>makeNewDrawingWithin (in category 'painting') -----
+ makeNewDrawingWithin
+ "Start a painting session in my interior which will result in a new SketchMorph being created as one of my submorphs"
+
+ | evt |
+ evt := MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand.
+ self makeNewDrawing: evt!
Item was added:
+ ----- Method: PasteUpMorph>>maxHeightToAvoidThumbnailing (in category 'misc') -----
+ maxHeightToAvoidThumbnailing
+ ^ self valueOfProperty: #maxHeightToAvoidThumbnailing ifAbsent: [80]!
Item was added:
+ ----- Method: PasteUpMorph>>maximumThumbnailWidth (in category 'misc') -----
+ maximumThumbnailWidth
+ ^ self valueOfProperty: #maximumThumbnailWidth ifAbsent: [200 min: (self width - 10)]!
Item was added:
+ ----- Method: PasteUpMorph>>modalLockTo: (in category 'polymorph') -----
+ modalLockTo: aSystemWindow
+ "Don't lock the world!! Lock the submorphs.
+ The modal window gets opened afterwards so is OK."
+
+ |lockStates|
+ lockStates := IdentityDictionary new.
+ self submorphsDo: [:m |
+ lockStates at: m put: m isLocked.
+ m lock].
+ self
+ setProperty: #submorphLockStates
+ toValue: lockStates!
Item was added:
+ ----- Method: PasteUpMorph>>modalUnlockFrom: (in category 'polymorph') -----
+ modalUnlockFrom: aSystemWindow
+ "Don't unlock the world!! Unlock the submorphs
+ that were not originally locked."
+
+ |lockStates|
+ lockStates := self
+ valueOfProperty: #submorphLockStates
+ ifAbsent: [^self].
+ self removeProperty: #submorphLockStates.
+ lockStates keysAndValuesDo: [:m :locked |
+ locked ifFalse: [m unlock]]!
Item was added:
+ ----- Method: PasteUpMorph>>modalWindow: (in category 'accessing') -----
+ modalWindow: aMorph
+ (self valueOfProperty: #modalWindow)
+ ifNotNil: [:morph | morph doCancel].
+ self setProperty: #modalWindow toValue: aMorph.
+ aMorph
+ ifNotNil: [self
+ when: #aboutToLeaveWorld
+ send: #removeModalWindow
+ to: self]!
Item was added:
+ ----- Method: PasteUpMorph>>model (in category 'model') -----
+ model
+ "Return the model object for this world. If the world has no model, then create one."
+
+ self createCustomModel.
+ ^ model!
Item was added:
+ ----- Method: PasteUpMorph>>modelOrNil (in category 'accessing') -----
+ modelOrNil
+ "Return the model object for this world, or nil if it doesn't have one."
+
+ ^ model
+ !
Item was added:
+ ----- Method: PasteUpMorph>>modelWakeUp (in category 'user interface') -----
+ modelWakeUp
+ "I am the model of a SystemWindow, that has just been activated"
+
+ | aWindow |
+ owner isNil ifTrue: [^self]. "Not in Morphic world"
+ (owner isKindOf: TransformMorph) ifTrue: [^self viewBox: self fullBounds].
+ (aWindow := self containingWindow) ifNotNil:
+ [self viewBox = aWindow panelRect
+ ifFalse: [self viewBox: aWindow panelRect]]!
Item was added:
+ ----- Method: PasteUpMorph>>morphToDropForTransferMorph: (in category 'dropping/grabbing') -----
+ morphToDropForTransferMorph: aTransferMorph
+ "aTransferMorph has been dragged directly onto the desktop. TransferMorphs, by nature, are about transferring a 'logical object' from another source. Answer the Morph that should actually be dropped on to the desktop."
+ ^ self
+ perform: self transferMorphConverter
+ with: aTransferMorph!
Item was added:
+ ----- Method: PasteUpMorph>>morphToDropFrom: (in category 'dropping/grabbing') -----
+ morphToDropFrom: aMorph
+ "Given a morph being carried by the hand, which the hand is about to drop, answer the actual morph to be deposited. Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service."
+
+ | aNail representee handy posBlock |
+ handy := self primaryHand.
+ posBlock :=
+ [:z | | tempPos |
+ tempPos := handy position
+ - ((handy targetOffset - aMorph formerPosition)
+ * (z extent / aMorph extent)) rounded.
+ self pointFromWorld: tempPos].
+ self alwaysShowThumbnail
+ ifTrue:
+ [aNail := aMorph
+ representativeNoTallerThan: self maxHeightToAvoidThumbnailing
+ norWiderThan: self maximumThumbnailWidth
+ thumbnailHeight: self heightForThumbnails.
+ aNail == aMorph
+ ifFalse:
+ [aMorph formerPosition: aMorph position.
+ aNail position: (posBlock value: aNail)].
+ ^aNail].
+ ((aMorph isKindOf: MorphThumbnail)
+ and: [(representee := aMorph morphRepresented) owner isNil])
+ ifTrue:
+ [representee position: (posBlock value: representee).
+ ^representee].
+ self showingListView
+ ifTrue:
+ [^aMorph
+ listViewLineForFieldList: (self valueOfProperty: #fieldListSelectors)].
+ (aMorph hasProperty: #newPermanentScript)
+ ifTrue: [^aMorph asEmptyPermanentScriptor].
+ ((aMorph isPhraseTileMorph) or: [aMorph isSyntaxMorph])
+ ifFalse: [^aMorph morphToDropInPasteUp: self].
+ aMorph userScriptSelector isEmptyOrNil
+ ifTrue:
+ ["non-user"
+
+ self automaticPhraseExpansion ifFalse: [^aMorph]].
+ ^aMorph morphToDropInPasteUp: self!
Item was added:
+ ----- Method: PasteUpMorph>>morphToGrab: (in category 'event handling') -----
+ morphToGrab: event
+ "Return the morph to grab from a mouse down event. If none, return nil."
+ self submorphsDo:[:m|
+ ((m rejectsEvent: event) not and:[m fullContainsPoint: event cursorPoint]) ifTrue:[^m].
+ ].
+ ^nil!
Item was added:
+ ----- Method: PasteUpMorph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+
+ self isFlap ifTrue:[^26]. "As navigators"
+ ^super morphicLayerNumber.!
Item was added:
+ ----- Method: PasteUpMorph>>morphsInFrontOf:overlapping:do: (in category 'submorphs-accessing') -----
+ morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock
+ "Include hands if the receiver is the World"
+ self handsDo:[:m|
+ m == someMorph ifTrue:["Try getting out quickly"
+ owner ifNil:[^self].
+ ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock].
+ "The hand only overlaps if it's not the hardware cursor"
+ m needsToBeDrawn ifTrue:[
+ (m fullBoundsInWorld intersects: aRectangle)
+ ifTrue:[aBlock value: m]]].
+ ^super morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock!
Item was added:
+ ----- Method: PasteUpMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "Handle a mouse down event."
+ | grabbedMorph handHadHalos |
+
+ (Preferences generalizedYellowButtonMenu
+ and: [evt yellowButtonPressed])
+ ifTrue: [^ self yellowButtonActivity: evt shiftPressed].
+
+ grabbedMorph := self morphToGrab: evt.
+ grabbedMorph ifNotNil:[
+ grabbedMorph isSticky ifTrue:[^self].
+ self isPartsBin ifFalse:[^evt hand grabMorph: grabbedMorph].
+ grabbedMorph := grabbedMorph partRepresented duplicate.
+ grabbedMorph restoreSuspendedEventHandler.
+ (grabbedMorph fullBounds containsPoint: evt position)
+ ifFalse:[grabbedMorph position: evt position].
+ "Note: grabbedMorph is ownerless after duplicate so use #grabMorph:from: instead"
+ ^ evt hand grabMorph: grabbedMorph from: self].
+
+ (super handlesMouseDown: evt)
+ ifTrue:[^super mouseDown: evt].
+
+ handHadHalos := evt hand halo notNil.
+
+ evt hand removeHalo. "shake off halos"
+ evt hand releaseKeyboardFocus. "shake of keyboard foci"
+
+ self submorphs
+ select:[:each | each hasProperty: #morphHierarchy]
+ thenDo:[:each | each delete].
+
+ Preferences noviceMode
+ ifTrue:[
+ self submorphs
+ select:[:each | (each isKindOf: MenuMorph) and:[each stayUp not]]
+ thenDo:[:each | each delete].
+ ].
+
+ (evt shiftPressed not
+ and:[ self isWorldMorph not
+ and:[ self wantsEasySelection not ]])
+ ifTrue:[
+ "explicitly ignore the event if we're not the world and we'll not select,
+ so that we could be picked up if need be"
+ evt wasHandled: false.
+ ^ self.
+ ].
+
+ ( evt shiftPressed or: [ self wantsEasySelection ] ) ifTrue:[
+ "We'll select on drag, let's decide what to do on click"
+ | clickSelector |
+
+ clickSelector := nil.
+
+ evt shiftPressed ifTrue:[
+ clickSelector := #findWindow:.
+ ]
+ ifFalse:[
+ self isWorldMorph ifTrue:[
+ clickSelector := handHadHalos
+ ifTrue: [ #delayedInvokeWorldMenu: ]
+ ifFalse: [ #invokeWorldMenu: ]
+ ]
+ ].
+
+ evt hand
+ waitForClicksOrDrag: self
+ event: evt
+ selectors: { clickSelector. nil. nil. #dragThroughOnDesktop: }
+ threshold: HandMorph dragThreshold.
+ ]
+ ifFalse:[
+ "We wont select, just bring world menu if I'm the world"
+ self isWorldMorph ifTrue:[
+ handHadHalos
+ ifTrue: [ self delayedInvokeWorldMenu: evt ]
+ ifFalse: [ self invokeWorldMenu: evt ]
+ ]
+ ].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>mouseOverHalosString (in category 'menu & halo') -----
+ mouseOverHalosString
+ "Answer the string to be shown in a menu to represent the
+ mouse-over-halos status"
+ ^ (self wantsMouseOverHalos
+ ifTrue: ['<on>']
+ ifFalse: ['<off>'])
+ , 'mouse-over halos' translated!
Item was added:
+ ----- Method: PasteUpMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+ self isWorldMorph ifTrue:[self removeAlarm: #invokeWorldMenu:].
+ super mouseUp: evt.!
Item was added:
+ ----- Method: PasteUpMorph>>mouseX (in category 'misc') -----
+ mouseX
+ "Answer the x-coordinate of the mouse, in my coordinate system"
+
+ ^ self isInWorld
+ ifTrue:
+ [((self pointFromWorld: self cursorPoint) x) - self cartesianOrigin x]
+ ifFalse:
+ [0]!
Item was added:
+ ----- Method: PasteUpMorph>>mouseY (in category 'misc') -----
+ mouseY
+ "Answer the y-coordinate of the mouse, in my coordinate system"
+
+ ^ self isInWorld
+ ifTrue:
+ [self cartesianOrigin y - ((self pointFromWorld: self cursorPoint) y)]
+ ifFalse:
+ [0]!
Item was added:
+ ----- Method: PasteUpMorph>>nameForCopyIfAlreadyNamed: (in category 'misc') -----
+ nameForCopyIfAlreadyNamed: aMorph
+ "Answer a name to set for a copy of aMorph if aMorph itself is named, else nil"
+
+ | aName usedNames |
+ ^ (aName := aMorph knownName) ifNotNil:
+ [usedNames := self allKnownNames.
+ Utilities keyLike: aName satisfying: [:f | (usedNames includes: f) not]]!
Item was added:
+ ----- Method: PasteUpMorph>>newDrawingFromMenu: (in category 'world menu') -----
+ newDrawingFromMenu: evt
+ self assureNotPaintingElse: [^ self].
+ evt hand attachMorph: PaintInvokingMorph new markAsPartsDonor!
Item was added:
+ ----- Method: PasteUpMorph>>newResourceLoaded (in category 'initialization') -----
+ newResourceLoaded
+ "Some resource has just been loaded. Notify all morphs in case somebody wants to update accordingly."
+ self allMorphsDo:[:m| m resourceJustLoaded ].
+ self fullRepaintNeeded.!
Item was added:
+ ----- Method: PasteUpMorph>>nextPage (in category 'world state') -----
+ nextPage
+ "backstop for smart next-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the 'next' button was not embedded in a book, so we can do nothing useful"
+
+ Beeper beep!
Item was added:
+ ----- Method: PasteUpMorph>>numberAtCursor (in category 'cursor') -----
+ numberAtCursor
+ "Answer the number represented by the object at my current cursor position"
+
+ | chosenMorph |
+ submorphs isEmpty ifTrue: [^ 0].
+ chosenMorph := submorphs at: ((cursor truncated max: 1) min: submorphs size).
+ ^ chosenMorph getNumericValue
+ !
Item was added:
+ ----- Method: PasteUpMorph>>offsetForAccommodating:onEdge: (in category 'flaps') -----
+ offsetForAccommodating: anExtent onEdge: edgeSymbol
+ "Answer a delta to be applied to my submorphs in order tfor anExtent to be slid inboard on the indicated edge"
+ edgeSymbol == #left ifTrue: [^ anExtent x @ 0].
+ edgeSymbol == #right ifTrue: [^ anExtent x negated @ 0].
+ edgeSymbol == #top ifTrue: [^ 0 @ anExtent y].
+ edgeSymbol == #bottom ifTrue: [^ 0 @ anExtent y negated].!
Item was added:
+ ----- Method: PasteUpMorph>>onceAgainDismiss: (in category 'undo') -----
+ onceAgainDismiss: aMorph
+ "Occasioned by a redo of a dismiss-via-halo"
+
+ aMorph dismissMorph.
+ TrashCanMorph preserveTrash ifTrue:
+ [TrashCanMorph slideDismissalsToTrash
+ ifTrue:[aMorph slideToTrash: nil]
+ ifFalse:[TrashCanMorph moveToTrash: aMorph]]!
Item was added:
+ ----- Method: PasteUpMorph>>openScrapsBook: (in category 'world menu') -----
+ openScrapsBook: evt
+ "Open up the Scraps book in the center of the screen"
+
+ evt hand world addMorphCentered: ScrapBook default scrapBook!
Item was added:
+ ----- Method: PasteUpMorph>>optimumExtentFromAuthor (in category 'world state') -----
+ optimumExtentFromAuthor
+
+
+ ^self
+ valueOfProperty: #optimumExtentFromAuthor
+ ifAbsent: [ | opt |
+ opt := bounds extent.
+ self setProperty: #optimumExtentFromAuthor toValue: opt.
+ ^opt
+ ]
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>originAtCenter (in category 'dropping/grabbing') -----
+ originAtCenter
+ ^ self hasProperty: #originAtCenter!
Item was added:
+ ----- Method: PasteUpMorph>>originAtCenterString (in category 'menu & halo') -----
+ originAtCenterString
+ "Answer the string to be shown in a menu to represent the
+ origin-at-center status"
+ ^ ((self hasProperty: #originAtCenter)
+ ifTrue: ['<on>']
+ ifFalse: ['<off>']), 'origin-at-center' translated!
Item was added:
+ ----- Method: PasteUpMorph>>padding: (in category 'misc') -----
+ padding: aNumber
+ padding := aNumber!
Item was added:
+ ----- Method: PasteUpMorph>>paintArea (in category 'world state') -----
+ paintArea
+ "What rectangle should the user be allowed to create a new painting in??
+ An area beside the paintBox. Allow playArea to override with its own
+ bounds!! "
+ | playfield paintBoxBounds |
+ playfield := self
+ submorphNamed: 'playfield'
+ ifNone: [].
+ playfield
+ ifNotNil: [^ playfield bounds].
+ paintBoxBounds := self paintBox bounds.
+ self firstHand targetPoint x < paintBoxBounds center x
+ ifTrue: [^ bounds topLeft corner: paintBoxBounds left @ bounds bottom"paint on left side"]
+ ifFalse: [^ paintBoxBounds right @ bounds top corner: bounds bottomRight]!
Item was added:
+ ----- Method: PasteUpMorph>>paintAreaFor: (in category 'world state') -----
+ paintAreaFor: aSketchMorph
+ "Answer the area to comprise the onion-skinned canvas for painting/repainting aSketchMorph"
+
+ | itsOwner |
+ ((itsOwner := aSketchMorph owner) notNil and: [itsOwner isPlayfieldLike])
+ ifTrue: [^itsOwner bounds]. "handles every plausible situation"
+ ^self paintArea!
Item was added:
+ ----- Method: PasteUpMorph>>paintBox (in category 'world state') -----
+ paintBox
+ "Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph, or if it has been deleted from this world, create a new one."
+
+ | newPaintBox refPoint aPalette |
+ self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]].
+ refPoint := (aPalette := self standardPalette)
+ ifNotNil:
+ [aPalette showNoPalette.
+ aPalette topRight + (0 @ 12)]
+ ifNil:
+ [self topRight].
+ newPaintBox := PaintBoxMorph new.
+ newPaintBox position: (refPoint - (newPaintBox width @ 0)).
+ self addMorph: newPaintBox.
+ ^ newPaintBox
+ !
Item was added:
+ ----- Method: PasteUpMorph>>paintBoxOrNil (in category 'world state') -----
+ paintBoxOrNil
+ "Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph return nil"
+
+ self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]].
+ ^ nil
+ !
Item was added:
+ ----- Method: PasteUpMorph>>paintingBoundsAround: (in category 'painting') -----
+ paintingBoundsAround: aPoint
+ "Return a rectangle for painting centered on the given point. Both the argument point and the result rectangle are in world coordinates."
+
+ | paintExtent maxPaintArea myBnds |
+ paintExtent := self reasonablePaintingExtent.
+ maxPaintArea := paintExtent x * paintExtent y.
+ myBnds := self boundsInWorld.
+ (myBnds area <= maxPaintArea) ifTrue: [^ myBnds].
+ ^ (aPoint - (paintExtent // 2) extent: paintExtent) intersect: myBnds
+ !
Item was added:
+ ----- Method: PasteUpMorph>>paintingFlapTab (in category 'flaps') -----
+ paintingFlapTab
+ "If the receiver has a flap which has a paintbox, return it, else return nil"
+ self flapTabs do:
+ [:aTab | aTab referent submorphsDo:
+ [:aMorph | (aMorph isKindOf: PaintBoxMorph) ifTrue: [^ aTab]]].
+ ^ nil!
Item was added:
+ ----- Method: PasteUpMorph>>patchAt:without:andNothingAbove: (in category 'world state') -----
+ patchAt: patchRect without: stopMorph andNothingAbove: stopThere
+ "Return a complete rendering of this patch of the display screen
+ without stopMorph, and possibly without anything above it."
+
+ | c |
+ c := ColorPatchCanvas
+ extent: patchRect extent
+ depth: Display depth
+ origin: patchRect topLeft negated
+ clipRect: (0 at 0 extent: patchRect extent).
+ c stopMorph: stopMorph.
+ c doStop: stopThere.
+
+ (self bounds containsRect: patchRect) ifFalse:
+ ["Need to fill area outside bounds with black."
+ c form fillColor: Color black].
+ (self bounds intersects: patchRect) ifFalse:
+ ["Nothing within bounds to show."
+ ^ c form].
+ self fullDrawOn: c.
+ stopThere ifFalse: [ self world handsReverseDo: [:h | h drawSubmorphsOn: c]].
+ ^c form
+ !
Item was added:
+ ----- Method: PasteUpMorph>>pauseEventRecorder (in category 'world state') -----
+ pauseEventRecorder
+ "Suspend any event recorder, and return it if found"
+
+
+ worldState handsDo: [:h | | er | (er := h pauseEventRecorderIn: self) ifNotNil: [^ er]].
+ ^ nil!
Item was added:
+ ----- Method: PasteUpMorph>>position: (in category 'geometry') -----
+ position: aPoint
+ "Prevent moving a world (e.g. via HandMorph>>specialGesture:)"
+
+ "for now, let's allow it and see what happens"
+
+ self isWorldMorph ifFalse: [^super position: aPoint].
+ super position: aPoint.
+ self viewBox ifNotNil: [self viewBox: (aPoint extent: self viewBox extent)].
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>positionNear:forExtent:adjustmentSuggestion: (in category 'dropping/grabbing') -----
+ positionNear: aPoint forExtent: anExtent adjustmentSuggestion: adjustmentPoint
+ "Compute a plausible positioning for adding a subpart of size anExtent, somewhere near aPoint, using adjustmentPoint as the unit of adjustment"
+
+ | adjustedPosition |
+ adjustedPosition := aPoint.
+ [((self morphsAt: (adjustedPosition + (anExtent // 2))) size > 1) and: "that 1 is self here"
+ [bounds containsPoint: adjustedPosition]]
+ whileTrue:
+ [adjustedPosition := adjustedPosition + adjustmentPoint].
+
+ ^ adjustedPosition!
Item was added:
+ ----- Method: PasteUpMorph>>prepareToBeSaved (in category 'misc') -----
+ prepareToBeSaved
+ "Prepare for export via the ReferenceStream mechanism"
+
+ | exportDict soundKeyList players |
+ super prepareToBeSaved.
+ turtlePen := nil.
+ self isWorldMorph
+ ifTrue:
+ [self removeProperty: #scriptsToResume.
+ soundKeyList := Set new.
+ (players := self presenter allExtantPlayers)
+ do: [:aPlayer | aPlayer slotInfo
+ associationsDo: [:assoc | assoc value type == #Sound
+ ifTrue: [soundKeyList
+ add: (aPlayer instVarNamed: assoc key)]]].
+ players
+ do: [:p | p allScriptEditors
+ do: [:e | (e allMorphs
+ select: [:m | m isSoundTile])
+ do: [:aTile | soundKeyList add: aTile literal]]].
+ (self allMorphs
+ select: [:m | m isSoundTile])
+ do: [:aTile | soundKeyList add: aTile literal].
+ soundKeyList removeAllFoundIn: SampledSound universalSoundKeys.
+ soundKeyList
+ removeAllSuchThat: [:aKey | (SampledSound soundLibrary includesKey: aKey) not].
+ soundKeyList isEmpty
+ ifFalse: [exportDict := Dictionary new.
+ soundKeyList
+ do: [:aKey | exportDict
+ add: (SampledSound soundLibrary associationAt: aKey)].
+ self setProperty: #soundAdditions toValue: exportDict]]!
Item was added:
+ ----- Method: PasteUpMorph>>prepareToPaint (in category 'painting') -----
+ prepareToPaint
+ "We're about to start painting. Do a few preparations that make the system more responsive."
+
+ ^ self prepareToPaint: Preferences keepTickingWhilePainting not!
Item was added:
+ ----- Method: PasteUpMorph>>prepareToPaint: (in category 'painting') -----
+ prepareToPaint: stopRunningScripts
+ "We're about to start painting. Do a few preparations that make the system more responsive."
+
+ self hideViewerFlaps. "make room"
+ stopRunningScripts ifTrue:
+ [self setProperty: #scriptsToResume toValue: self presenter allCurrentlyTickingScriptInstantiations. "We'll restart these when painting is done"
+ self stopRunningAll]. "stop scripts"
+ self abandonAllHalos. "no more halos"!
Item was added:
+ ----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') -----
+ presentCardAndStackMenu
+ "Put up a menu holding card/stack-related options."
+
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu addStayUpItem.
+ aMenu addTitle: 'card und stack'.
+ aMenu add: 'add new card' action: #insertCard.
+ aMenu add: 'delete this card' action: #deleteCard.
+ aMenu add: 'go to next card' action: #goToNextCardInStack.
+ aMenu add: 'go to previous card' action: #goToPreviousCardInStack.
+ aMenu addLine.
+ aMenu add: 'show foreground objects' action: #showForegroundObjects.
+ aMenu add: 'show background objects' action: #showBackgroundObjects.
+ aMenu add: 'show designations' action: #showDesignationsOfObjects.
+ aMenu add: 'explain designations' action: #explainDesignations.
+ aMenu popUpInWorld: (self world ifNil: [self currentWorld])!
Item was added:
+ ----- Method: PasteUpMorph>>presentPlayfieldMenu (in category 'menu & halo') -----
+ presentPlayfieldMenu
+
+ self playfieldOptionsMenu popUpForHand: self activeHand in: self world!
Item was added:
+ ----- Method: PasteUpMorph>>presenter (in category 'accessing') -----
+ presenter
+ "Normally only the world will have a presenter, but the architecture supports individual localized presenters as well"
+
+ ^ presenter ifNil:
+ [self isWorldMorph
+ ifTrue: [presenter := Presenter defaultPresenterClass new associatedMorph: self]
+ ifFalse: [super presenter]]!
Item was added:
+ ----- Method: PasteUpMorph>>previousPage (in category 'world state') -----
+ previousPage
+ "backstop for smartprev-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the button was not embedded in a book, so we can do nothing useful"
+
+ Beeper beep!
Item was added:
+ ----- Method: PasteUpMorph>>printOn: (in category 'printing') -----
+ printOn: aStream
+ "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is"
+
+ super printOn: aStream.
+ self isWorldMorph ifTrue: [aStream nextPutAll: ' [world]']!
Item was added:
+ ----- Method: PasteUpMorph>>printScriptSummary (in category 'world menu') -----
+ printScriptSummary
+ "Put up a window with summaries of all scripts in the world"
+
+ self presenter reportPlayersAndScripts
+
+ "self currentWorld printScriptSummary"!
Item was added:
+ ----- Method: PasteUpMorph>>privateFullMoveBy: (in category 'private') -----
+ privateFullMoveBy: delta
+ "Private. Overridden to prevent drawing turtle trails when a playfield is moved"
+ self setProperty: #turtleTrailsDelta toValue: delta.
+ super privateFullMoveBy: delta.
+ self removeProperty: #turtleTrailsDelta.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>privateMoveBy: (in category 'private') -----
+ privateMoveBy: delta
+
+ super privateMoveBy: delta.
+ worldState ifNotNil: [
+ worldState viewBox ifNotNil: [
+ worldState viewBox: bounds
+ ].
+ ].!
Item was added:
+ ----- Method: PasteUpMorph>>privateOuterDisplayWorld (in category 'world state') -----
+ privateOuterDisplayWorld
+
+ worldState displayWorld: self submorphs: submorphs
+ !
Item was added:
+ ----- Method: PasteUpMorph>>privateRemoveMorph: (in category 'private') -----
+ privateRemoveMorph: aMorph
+ backgroundMorph == aMorph ifTrue: [ backgroundMorph := nil ].
+ ^super privateRemoveMorph: aMorph.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>processEvent:using: (in category 'events-processing') -----
+ processEvent: anEvent using: defaultDispatcher
+ "Reimplemented to install the receiver as the new ActiveWorld if it is one"
+ | priorWorld result |
+ self isWorldMorph ifFalse:[^super processEvent: anEvent using: defaultDispatcher].
+ priorWorld := ActiveWorld.
+ ActiveWorld := self.
+ result := super processEvent: anEvent using: defaultDispatcher.
+ ActiveWorld := priorWorld.
+ ^result!
Item was added:
+ ----- Method: PasteUpMorph>>project (in category 'project') -----
+ project
+ "Find the project that owns me. Not efficient to call this."
+
+ ^ Project ofWorld: self!
Item was added:
+ ----- Method: PasteUpMorph>>putUpNewMorphMenu (in category 'world menu') -----
+ putUpNewMorphMenu
+ "Put up the New Morph menu in the world"
+
+ TheWorldMenu new adaptToWorld: self; newMorph!
Item was added:
+ ----- Method: PasteUpMorph>>putUpPenTrailsSubmenu (in category 'menu & halo') -----
+ putUpPenTrailsSubmenu
+ "Put up the pen trails menu"
+
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu title: 'pen trails' translated.
+ aMenu addStayUpItem.
+ self addPenTrailsMenuItemsTo: aMenu.
+ aMenu popUpInWorld: ActiveWorld!
Item was added:
+ ----- Method: PasteUpMorph>>putUpWorldMenu: (in category 'world menu') -----
+ putUpWorldMenu: evt
+ "Put up a menu in response to a click on the desktop, triggered by evt."
+
+ | menu |
+ self bringTopmostsToFront.
+ evt isMouse ifTrue:
+ [evt yellowButtonPressed
+ ifTrue: [^ self yellowButtonClickOnDesktopWithEvent: evt].
+ evt shiftPressed ifTrue:[^ self findWindow: evt]].
+ "put up screen menu"
+ menu := self buildWorldMenu: evt.
+ menu addTitle: Preferences desktopMenuTitle translated.
+ menu popUpEvent: evt in: self.
+ ^ menu!
Item was added:
+ ----- Method: PasteUpMorph>>putUpWorldMenuFromEscapeKey (in category 'world menu') -----
+ putUpWorldMenuFromEscapeKey
+ Preferences noviceMode
+ ifFalse: [self putUpWorldMenu: ActiveEvent]!
Item was added:
+ ----- Method: PasteUpMorph>>reasonablePaintingExtent (in category 'painting') -----
+ reasonablePaintingExtent
+ ^ Preferences unlimitedPaintArea
+ ifTrue:
+ [3000 @ 3000]
+ ifFalse:
+ [Preferences defaultPaintingExtent]!
Item was added:
+ ----- Method: PasteUpMorph>>rectifyCursor (in category 'cursor') -----
+ rectifyCursor
+ cursor := ((cursor truncated max: 1) min: submorphs size)
+ !
Item was added:
+ ----- Method: PasteUpMorph>>referencePlayfield (in category 'e-toy support') -----
+ referencePlayfield
+ "Answer a pasteup morph to be used as the reference for cartesian coordinates.
+ Do not get fooled by other morphs (like viewers) that happen to be named 'playfield'."
+
+ ^self isWorldMorph
+ ifTrue: [ self submorphThat: [ :s | (s knownName = 'playfield') and: [ s isPlayfieldLike] ] ifNone: [self]]
+ ifFalse: [ super referencePlayfield ]!
Item was added:
+ ----- Method: PasteUpMorph>>reformulateUpdatingMenus (in category 'menu & halo') -----
+ reformulateUpdatingMenus
+ "Give any updating menu morphs in the receiver a fresh kiss of life"
+
+ (self submorphs select: [:m | m isKindOf: UpdatingMenuMorph]) do:
+ [:m | m updateMenu]
+
+ "NB: to do the perfect job here one might well want to extend across allMorphs here, but the expense upon project entry is seemingly too high a price to pay at this point"!
Item was added:
+ ----- Method: PasteUpMorph>>reintroduceIntoWorld: (in category 'undo') -----
+ reintroduceIntoWorld: aMorph
+ "The given morph is being raised from the dead. Bring it back to life."
+
+ (aMorph valueOfProperty: #lastPosition) ifNotNil:
+ [:pos | aMorph position: pos].
+ aMorph openInWorld; goHome
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>releaseCachedState (in category 'caching') -----
+ releaseCachedState
+ super releaseCachedState.
+ self removeModalWindow.
+ presenter ifNotNil:[presenter flushPlayerListCache].
+ self isWorldMorph ifTrue:[self cleanseStepList].!
Item was added:
+ ----- Method: PasteUpMorph>>releaseRemoteServer (in category 'Nebraska') -----
+ releaseRemoteServer
+ "My server has been transferred to some other world. Release pending references"
+ ^worldState releaseRemoteServer.!
Item was added:
+ ----- Method: PasteUpMorph>>releaseSqueakPages (in category 'project') -----
+ releaseSqueakPages
+
+ "If this world has a book with SqueakPages, then clear the SqueakPageCache"
+
+ submorphs do: [:sub | | uu |
+ (sub isKindOf: BookMorph) ifTrue: [
+ uu := sub valueOfProperty: #url ifAbsent: [nil].
+ uu ifNotNil: [(SqueakPageCache pageCache includesKey: uu) ifTrue: [
+ SqueakPageCache initialize]]]]. "wipe the cache"!
Item was added:
+ ----- Method: PasteUpMorph>>releaseViewers (in category 'flaps') -----
+ releaseViewers
+ "In preparation for saving, make the flapTabs release their viewers."
+
+ self flapTabs do: [:ft |
+ (ft respondsTo: #hibernate) ifTrue: [ft hibernate]]!
Item was added:
+ ----- Method: PasteUpMorph>>remoteServer (in category 'Nebraska') -----
+ remoteServer
+ ^worldState remoteServer.!
Item was added:
+ ----- Method: PasteUpMorph>>remoteServer: (in category 'Nebraska') -----
+ remoteServer: aNebraskaServer
+
+ | h |
+
+ worldState remoteServer: aNebraskaServer.
+ h := self primaryHand.
+ aNebraskaServer ifNil:[
+ (h hasProperty: #representingTheServer) ifTrue: [
+ h removeProperty: #representingTheServer.
+ h userInitials: '' andPicture: nil.
+ ]
+ ] ifNotNil:[
+ (h hasProperty: #representingTheServer) ifFalse: [
+ h setProperty: #representingTheServer toValue: true.
+ h userInitials: Utilities authorName andPicture: nil.
+ ]
+ ].!
Item was added:
+ ----- Method: PasteUpMorph>>removeAccommodationForFlap: (in category 'flaps') -----
+ removeAccommodationForFlap: aFlapTab
+ "Shift submorphs over, if appropriate"
+ | offset |
+ aFlapTab slidesOtherObjects ifTrue:
+ [offset := self offsetForAccommodating: aFlapTab referent extent onEdge: aFlapTab edgeToAdhereTo.
+ self shiftSubmorphsBy: offset negated]!
Item was added:
+ ----- Method: PasteUpMorph>>removeAlarm:for: (in category 'alarms-scheduler') -----
+ removeAlarm: aSelector for: aTarget
+ "Remove the alarm with the given selector"
+ worldState removeAlarm: aSelector for: aTarget!
Item was added:
+ ----- Method: PasteUpMorph>>removeAllViewers (in category 'world menu') -----
+ removeAllViewers
+ "Delete all the viewers lined up along my right margin."
+
+ (self submorphs select: [:m | m isKindOf: ViewerFlapTab]) do:
+ [:m |
+ m referent ifNotNil: [m referent delete].
+ m delete.]!
Item was added:
+ ----- Method: PasteUpMorph>>removeHand: (in category 'world state') -----
+ removeHand: aHandMorph
+ "Remove the given hand from the list of hands for this world."
+
+ (worldState hands includes: aHandMorph) ifFalse: [^self].
+ aHandMorph dropMorphs.
+ self invalidRect: aHandMorph fullBounds.
+ worldState removeHand: aHandMorph.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>removeModalWindow (in category 'accessing') -----
+ removeModalWindow
+ self modalWindow: nil!
Item was added:
+ ----- Method: PasteUpMorph>>removeRemoteClient: (in category 'Nebraska') -----
+ removeRemoteClient: aClient
+ self removeHand: aClient hand.
+ worldState removeRemoteCanvas: aClient canvas.
+ self changed. "force a redraw"
+ !
Item was added:
+ ----- Method: PasteUpMorph>>repairEmbeddedWorlds (in category 'world state') -----
+ repairEmbeddedWorlds
+
+ | toDoList |
+
+ toDoList := OrderedCollection new.
+ self allMorphsDo: [ :each | | transform eWorld |
+ (each isKindOf: EmbeddedWorldBorderMorph) ifTrue: [
+ transform := each submorphs at: 1 ifAbsent: [nil].
+ transform ifNotNil: [
+ eWorld := transform submorphs at: 1 ifAbsent: [nil].
+ eWorld ifNotNil: [
+ toDoList add: {transform. eWorld}.
+ ].
+ ].
+ "Smalltalk at: #Q put: {self. each. transform. eWorld}."
+ ].
+ ].
+ toDoList do: [ :each |
+ each first addMorph: each second.
+ ].!
Item was added:
+ ----- Method: PasteUpMorph>>repelsMorph:event: (in category 'dropping/grabbing') -----
+ repelsMorph: aMorph event: ev
+ (aMorph wantsToBeDroppedInto: self) ifFalse: [^ false].
+ self dropEnabled ifFalse: [^ true].
+ (self wantsDroppedMorph: aMorph event: ev) ifFalse: [^ true].
+ ^ super repelsMorph: aMorph event: ev "consults #repelling flag"!
Item was added:
+ ----- Method: PasteUpMorph>>replaceTallSubmorphsByThumbnails (in category 'options') -----
+ replaceTallSubmorphsByThumbnails
+ "Any submorphs that seem to tall get replaced by thumbnails; their balloon text is copied over to the thumbnail"
+
+ | heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails |
+ heightForThumbnails := self heightForThumbnails.
+ maxHeightToAvoidThumbnailing := self maxHeightToAvoidThumbnailing.
+ maxWidthForThumbnails := self maximumThumbnailWidth.
+ self submorphs do:
+ [:aMorph | | existingHelp itsThumbnail |
+ itsThumbnail := aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails.
+ (aMorph == itsThumbnail)
+ ifFalse:
+ [existingHelp := aMorph balloonText.
+ self replaceSubmorph: aMorph by: itsThumbnail.
+ existingHelp ifNotNil:
+ [itsThumbnail setBalloonText: existingHelp]]]!
Item was added:
+ ----- Method: PasteUpMorph>>reportLocalAddress (in category 'world menu') -----
+ reportLocalAddress
+ "Report the local host address of this computer."
+
+ | addrString m s |
+ Socket initializeNetwork.
+ addrString := NetNameResolver localAddressString.
+ m := RectangleMorph new
+ color: (Color r: 0.6 g: 0.8 b: 0.6);
+ extent: 118 at 36;
+ borderWidth: 1.
+ s := StringMorph contents: 'Local Host Address:'.
+ s position: m position + (5 at 4).
+ m addMorph: s.
+ s := StringMorph contents: addrString.
+ s position: m position + (5 at 19).
+ m addMorph: s.
+ self primaryHand attachMorph: m.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>repositionFlapsAfterScreenSizeChange (in category 'world state') -----
+ repositionFlapsAfterScreenSizeChange
+ "Reposition flaps after screen size change"
+
+ (Flaps globalFlapTabsIfAny, ActiveWorld localFlapTabs) do:
+ [:aFlapTab |
+ aFlapTab applyEdgeFractionWithin: self bounds].
+ Flaps doAutomaticLayoutOfFlapsIfAppropriate!
Item was added:
+ ----- Method: PasteUpMorph>>resetTransferMorphConverter (in category 'dropping/grabbing') -----
+ resetTransferMorphConverter
+ ^ self transferMorphConverter: #yourself!
Item was added:
+ ----- Method: PasteUpMorph>>residesInPartsBin (in category 'parts bin') -----
+ residesInPartsBin
+ "Answer true if the receiver is, or has some ancestor owner who is, a parts bin"
+
+ self isWorldMorph
+ ifTrue: [^ self isPartsBin]
+ ifFalse: [^ self isPartsBin or: [super residesInPartsBin]]!
Item was added:
+ ----- Method: PasteUpMorph>>resizeToFit (in category 'options') -----
+ resizeToFit
+ ^self vResizing == #shrinkWrap!
Item was added:
+ ----- Method: PasteUpMorph>>resizeToFitString (in category 'options') -----
+ resizeToFitString
+ "Answer a string, to be used in a self-updating menu, to
+ represent whether the receiver is currently using resize-to-fit
+ or not"
+ ^ (self resizeToFit
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ , 'resize to fit' translated!
Item was added:
+ ----- Method: PasteUpMorph>>respondToCommand:bySending:to: (in category 'world menu') -----
+ respondToCommand: aCharacter bySending: aSelector to: aReceiver
+ "Respond to the command-key use of the given character by sending the given selector to the given receiver. If the selector is nil, retract any prior such setting"
+
+ aSelector
+ ifNil:
+ [self commandKeySelectors removeKey: aCharacter]
+ ifNotNil:
+ [self commandKeySelectors at: aCharacter put: (MessageSend receiver: aReceiver selector: aSelector)]!
Item was added:
+ ----- Method: PasteUpMorph>>restartWorldCycleWithEvent: (in category 'WiW support') -----
+ restartWorldCycleWithEvent: evt
+
+ "RAA 27 Nov 99 - redispatch that click picked up from our inner world"
+ evt ifNotNil: [
+ self primaryHand handleEvent: (evt setHand: self primaryHand).
+ ].
+ Project current spawnNewProcessAndTerminateOld: true
+ !
Item was added:
+ ----- Method: PasteUpMorph>>restoreBoundsOfSubmorphs (in category 'viewing') -----
+ restoreBoundsOfSubmorphs
+ "restores the saved xy-positions and extents"
+
+ submorphs do:
+ [:aSubmorph |
+ aSubmorph valueOfProperty: #savedExtent ifPresentDo:
+ [:anExtent | aSubmorph extent: anExtent].
+ aSubmorph valueOfProperty: #savedPosition ifPresentDo:
+ [:aPosition | aSubmorph position: aPosition]]!
Item was added:
+ ----- Method: PasteUpMorph>>restoreDisplay (in category 'world state') -----
+ restoreDisplay
+
+ World restoreMorphicDisplay. "I don't actually expect this to be called"!
Item was added:
+ ----- Method: PasteUpMorph>>restoreFlapsDisplay (in category 'world state') -----
+ restoreFlapsDisplay
+ "Restore the display of flaps"
+
+ (Flaps sharedFlapsAllowed and: [Project current flapsSuppressed not]) ifTrue:
+ [Flaps globalFlapTabs do:
+ [:aFlapTab | aFlapTab adaptToWorld]].
+ self localFlapTabs do:
+ [:aFlapTab | aFlapTab adaptToWorld].
+ self assureFlapTabsFitOnScreen.
+ self bringTopmostsToFront.!
Item was added:
+ ----- Method: PasteUpMorph>>restoreMainDockingBarDisplay (in category 'world state') -----
+ restoreMainDockingBarDisplay
+ "Restore the display of docking bars"
+ self dockingBars
+ do: [:each | each updateBounds]!
Item was added:
+ ----- Method: PasteUpMorph>>restoreMorphicDisplay (in category 'world state') -----
+ restoreMorphicDisplay
+
+ DisplayScreen startUp.
+
+ ThumbnailMorph recursionReset.
+
+ self
+ extent: Display extent;
+ viewBox: Display boundingBox;
+ handsDo: [:h | h visible: true; showTemporaryCursor: nil];
+ restoreFlapsDisplay;
+ restoreMainDockingBarDisplay;
+ fullRepaintNeeded.
+
+ WorldState
+ addDeferredUIMessage: [Cursor normal show].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>resumeScriptsPausedByPainting (in category 'painting') -----
+ resumeScriptsPausedByPainting
+ "If there were any scripts running when painting was initiated, resume them now"
+
+ | aList |
+ (aList := self valueOfProperty: #scriptsToResume) isEmptyOrNil ifFalse:
+ [aList do:
+ [:aScriptInstantiation |
+ aScriptInstantiation player costume isInWorld ifTrue:
+ [aScriptInstantiation startRunningIfPaused]]].
+ self removeProperty: #scriptsToResume!
Item was added:
+ ----- Method: PasteUpMorph>>runLocalStepMethods (in category 'stepping') -----
+ runLocalStepMethods
+
+ worldState runLocalStepMethodsIn: self
+ !
Item was added:
+ ----- Method: PasteUpMorph>>runStepMethods (in category 'stepping') -----
+ runStepMethods
+
+ worldState runStepMethodsIn: self
+ !
Item was added:
+ ----- Method: PasteUpMorph>>saveAsWorld (in category 'world state') -----
+ saveAsWorld
+ | worldName s |
+ worldName := UIManager default
+ request: 'Please give this world a name'
+ initialAnswer: 'test'.
+ ((self class class includesSelector: worldName asSymbol) and:
+ [(UIManager default confirm: 'OK to overwrite ' , worldName , '?') not])
+ ifTrue: [^ self].
+
+ s := WriteStream on: (String new: 1000).
+ s nextPutAll: worldName; cr; tab;
+ nextPutAll: '"' , self class name , ' ' , worldName, ' open"'; cr; cr; tab;
+ nextPutAll: '^ '.
+ self printConstructorOn: s indent: 0.
+ s cr.
+
+ self class class
+ compile: s contents
+ classified: 'examples'
+ notifying: nil.!
Item was added:
+ ----- Method: PasteUpMorph>>saveBoundsOfSubmorphs (in category 'viewing') -----
+ saveBoundsOfSubmorphs
+ "store the current xy-positions and extents of submorphs for future use"
+
+ submorphs do:
+ [:aSubmorph |
+ aSubmorph setProperty: #savedExtent toValue: aSubmorph extent.
+ aSubmorph setProperty: #savedPosition toValue: aSubmorph position]!
Item was added:
+ ----- Method: PasteUpMorph>>saveOnFile (in category 'objects from disk') -----
+ saveOnFile
+ "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out."
+
+ | aFileName fileStream ok |
+
+ self flag: #bob0302.
+ self isWorldMorph ifTrue: [^self project saveAs].
+
+ aFileName := ('my {1}' translated format: {self class name}) asFileName. "do better?"
+ aFileName := UIManager default request: 'File name? (".project" will be added to end)' translated
+ initialAnswer: aFileName.
+ aFileName isEmpty ifTrue: [^ Beeper beep].
+ self allMorphsDo: [:m | m prepareToBeSaved].
+
+ ok := aFileName endsWith: '.project'. "don't double them"
+ ok := ok | (aFileName endsWith: '.sp').
+ ok ifFalse: [aFileName := aFileName,'.project'].
+ fileStream := FileStream newFileNamed: aFileName asFileName.
+ fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"!
Item was added:
+ ----- Method: PasteUpMorph>>selectedRect (in category 'cursor') -----
+ selectedRect
+ "Return a rectangle enclosing the morph at the current cursor. Note that the cursor may be a float and may be out of range, so pick the nearest morph. Assume there is at least one submorph."
+
+ | p |
+ p := cursor asInteger.
+ p := p min: submorphs size.
+ p := p max: 1.
+ ^(submorphs at: p) fullBounds expandBy: 2!
Item was added:
+ ----- Method: PasteUpMorph>>sendTextContentsBackToDonor (in category 'menu & halo') -----
+ sendTextContentsBackToDonor
+ "Send my string contents back to the Text Morph from whence I came"
+
+ (self valueOfProperty: #donorTextMorph) ifNotNil:
+ [:aDonor | aDonor setCharacters: self assuredPlayer getStringContents]!
Item was added:
+ ----- Method: PasteUpMorph>>setGradientColor: (in category 'display') -----
+ setGradientColor: evt
+ "For backwards compatibility with GradientFillMorph"
+
+ self flag: #fixThis.
+ self changeColorTarget: self selector: #gradientFillColor:
+ originalColor: (self fillStyle isGradientFill
+ ifTrue: [self fillStyle colorRamp last value]
+ ifFalse: [color])
+ hand: evt hand.!
Item was added:
+ ----- Method: PasteUpMorph>>setGridSpec (in category 'gridding') -----
+ setGridSpec
+ "Gridding rectangle provides origin and modulus"
+ | response result |
+ response := UIManager default
+ request: 'New grid origin (usually 0 at 0):' translated
+ initialAnswer: self gridOrigin printString.
+ response isEmpty ifTrue: [^ self].
+ result := [Compiler evaluate: response] ifError: [^ self].
+ (result isPoint and: [(result >= (0 at 0))])
+ ifTrue: [self gridOrigin: result]
+ ifFalse: [self inform: ('Must be a Point with coordinates (for example 10 at 10)' translated )].
+
+ response := UIManager default
+ request: 'New grid spacing:' translated
+ initialAnswer: self gridModulus printString.
+ response isEmpty ifTrue: [^ self].
+ result := [Compiler evaluate: response] ifError: [^ self].
+ (result isPoint and: [(result > (0 at 0)) ])
+ ifTrue: [self gridModulus: result]
+ ifFalse: [self inform: ('Must be a Point with coordinates (for example 10 at 10)' translated )].
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>setModel: (in category 'model') -----
+ setModel: aModelMorph
+ "Set the model for this world. Methods for sensitized morphs will be compiled into the class for this model."
+
+ model := aModelMorph
+ !
Item was added:
+ ----- Method: PasteUpMorph>>setPartsBinStatusTo: (in category 'options') -----
+ setPartsBinStatusTo: aBoolean
+ isPartsBin := aBoolean.
+ aBoolean ifFalse: [self enableDragNDrop].
+ "but note that we no longer reset openToDragNDrop to false upon making it a parts bin again"
+ isPartsBin
+ ifTrue:
+ [submorphs do:
+ [:m | m isPartsDonor: true.
+ m stopStepping.
+ m suspendEventHandler]]
+ ifFalse:
+ [submorphs do:
+ [:m | m isPartsDonor: false.
+ m restoreSuspendedEventHandler].
+ self world ifNotNil: [self world startSteppingSubmorphsOf: self]]!
Item was added:
+ ----- Method: PasteUpMorph>>shouldGetStepsFrom: (in category 'WiW support') -----
+ shouldGetStepsFrom: aWorld
+
+ (self isWorldMorph and: [owner notNil]) ifTrue: [
+ ^self outermostWorldMorph == aWorld
+ ].
+ ^super shouldGetStepsFrom: aWorld!
Item was added:
+ ----- Method: PasteUpMorph>>showApplicationView (in category 'menu & halo') -----
+ showApplicationView
+
+ self transformToShow: (self valueOfProperty: #applicationViewBounds ifAbsent: [bounds])
+ !
Item was added:
+ ----- Method: PasteUpMorph>>showExpandedView (in category 'menu & halo') -----
+ showExpandedView
+
+ owner "the transform"
+ owner "the green border"
+ bounds: Display boundingBox!
Item was added:
+ ----- Method: PasteUpMorph>>showFactoryView (in category 'menu & halo') -----
+ showFactoryView
+
+ self transformToShow: (self valueOfProperty: #factoryViewBounds ifAbsent: [bounds])
+ !
Item was added:
+ ----- Method: PasteUpMorph>>showFullView (in category 'menu & halo') -----
+ showFullView
+
+ self transformToShow: bounds
+ !
Item was added:
+ ----- Method: PasteUpMorph>>showReducedView (in category 'menu & halo') -----
+ showReducedView
+
+ | r |
+ r := Display extent // 4 extent: Display extent // 2.
+ owner "the transform"
+ owner "the green border"
+ bounds: r!
Item was added:
+ ----- Method: PasteUpMorph>>showStatusOfAllScripts (in category 'world menu') -----
+ showStatusOfAllScripts
+ "Put up a window that shows, and allows you to change, the status of all scripts"
+
+ self presenter toolToViewScriptInstantiations!
Item was added:
+ ----- Method: PasteUpMorph>>showThumbnailString (in category 'menu & halo') -----
+ showThumbnailString
+ "Answer the string to be shown in a menu to represent the
+ show-thumbnails status"
+ ^ ((self hasProperty: #alwaysShowThumbnail)
+ ifTrue: ['<on>']
+ ifFalse: ['<off>']), 'show thumbnails' translated!
Item was added:
+ ----- Method: PasteUpMorph>>showWorldMainDockingBarString (in category 'menu & halo') -----
+ showWorldMainDockingBarString
+ ^ self project showWorldMainDockingBarString!
Item was added:
+ ----- Method: PasteUpMorph>>showingListView (in category 'viewing') -----
+ showingListView
+ "Answer whether the receiver is currently showing a list view"
+
+ ^ self hasProperty: #showingListView
+ !
Item was added:
+ ----- Method: PasteUpMorph>>sketchEditorOrNil (in category 'world state') -----
+ sketchEditorOrNil
+ "Return a SketchEditorMorph found in the world, if any, else nil"
+
+ ^ self findA: SketchEditorMorph
+ !
Item was added:
+ ----- Method: PasteUpMorph>>sleep (in category 'world state') -----
+ sleep
+
+ self flag: #bob. "Alan wanted this"
+
+ worldState canvas ifNil: [^ self "already called (clean this up)"].
+ Cursor normal show. "restore the normal cursor"
+
+ ">>>> Alan wanted this out
+ (turtleTrailsForm ~~ nil and: [self confirm: 'May I clear the pen trails
+ in this worldState to save space?']) ifTrue: [self clearTurtleTrails].
+ <<<<<"
+
+ worldState canvas: nil. "free my canvas to save space"
+ self fullReleaseCachedState.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>smallThumbnailForPageSorter (in category 'misc') -----
+ smallThumbnailForPageSorter
+
+ ^ self cachedOrNewThumbnailFrom: BookPageThumbnailMorph new smaller!
Item was added:
+ ----- Method: PasteUpMorph>>someHalo (in category 'world state') -----
+ someHalo
+ "Return some halo that's currently visible in the world"
+
+ | m |
+ ^(m := self haloMorphs) notEmpty ifTrue: [m first] ifFalse: [nil]!
Item was added:
+ ----- Method: PasteUpMorph>>sortSubmorphsBy: (in category 'viewing') -----
+ sortSubmorphsBy: sortOrderSymbol
+ "Sort the receiver's submorphs by the criterion indicated in the provided symbol"
+ self invalidRect: self fullBounds.
+ submorphs := submorphs sortBy:[:a :b | (a perform: sortOrderSymbol) <= (b perform: sortOrderSymbol)].
+ self layoutChanged.!
Item was added:
+ ----- Method: PasteUpMorph>>specialNameInModelFor: (in category 'world state') -----
+ specialNameInModelFor: aMorph
+ ^ model ifNotNil: [model nameFor: aMorph] ifNil: [nil]!
Item was added:
+ ----- Method: PasteUpMorph>>standardPlayerHit (in category 'world state') -----
+ standardPlayerHit
+
+ self playSoundNamed: 'peaks'.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>standardSystemController (in category 'world state') -----
+ standardSystemController
+ ^ScheduledControllers controllerSatisfying:
+ [:c |
+ c view subViews notEmpty and: [c view firstSubView model == self]]!
Item was added:
+ ----- Method: PasteUpMorph>>startBackgroundProcess (in category 'update cycle') -----
+ startBackgroundProcess
+ "Start a process to update this world in the background. Return the process created."
+
+ | p |
+ p := [ [
+ self doOneCycleInBackground.
+ (Delay forMilliseconds: 20) wait] repeat ] newProcess.
+ p resume.
+ ^ p
+ !
Item was added:
+ ----- Method: PasteUpMorph>>startRunningAll (in category 'misc') -----
+ startRunningAll
+ "Start running all scripted morphs. Triggered by user hitting GO button"
+
+ self presenter flushPlayerListCache. "Inefficient, but makes sure things come right whenever GO hit"
+ self presenter allExtantPlayers do: [:aPlayer | aPlayer costume residesInPartsBin ifFalse: [aPlayer startRunning]].
+ self allScriptors do:
+ [:aScriptor | aScriptor startRunningIfPaused].
+
+ self world updateStatusForAllScriptEditors!
Item was added:
+ ----- Method: PasteUpMorph>>startStepping: (in category 'stepping') -----
+ startStepping: aMorph
+ "Add the given morph to the step list. Do nothing if it is already being stepped."
+ ^self startStepping: aMorph at: Time millisecondClockValue selector: #stepAt: arguments: nil stepTime: nil!
Item was added:
+ ----- Method: PasteUpMorph>>startStepping:at:selector:arguments:stepTime: (in category 'stepping') -----
+ startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime
+ worldState startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime.!
Item was added:
+ ----- Method: PasteUpMorph>>startSteppingSubmorphsOf: (in category 'world state') -----
+ startSteppingSubmorphsOf: aMorph
+
+ "Ensure that all submorphs of the given morph that want to be stepped are added to the step list. Typically used after adding a morph to the world."
+
+ aMorph allMorphsDo: [:m |
+ m wantsSteps ifTrue: [m arrangeToStartSteppingIn: m world].
+ ]
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>step (in category 'stepping and presenter') -----
+ step
+
+ (self isWorldMorph and: [owner notNil]) ifTrue: [
+ ^self runLocalStepMethods
+ ].
+ super step!
Item was added:
+ ----- Method: PasteUpMorph>>stepAll (in category 'misc') -----
+ stepAll
+ "tick all the paused player scripts in the receiver"
+
+ self presenter allExtantPlayers do:
+ [:aPlayer |
+ aPlayer startRunning; step; stopRunning].
+
+ self allScriptors do:
+ [:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>stepListSize (in category 'project state') -----
+ stepListSize
+ ^ worldState stepListSize
+
+ "Transcript cr; show: self currentWorld stepListSize printString, ' items on steplist as of ', Date dateAndTimeNow printString"!
Item was added:
+ ----- Method: PasteUpMorph>>stepListSummary (in category 'project state') -----
+ stepListSummary
+ ^ worldState stepListSummary
+
+ "Transcript cr show: self currentWorld stepListSummary"!
Item was added:
+ ----- Method: PasteUpMorph>>stepTime (in category 'testing') -----
+ stepTime
+
+ (self isWorldMorph and: [owner notNil]) ifTrue: [
+ ^1
+ ].
+ ^super stepTime!
Item was added:
+ ----- Method: PasteUpMorph>>steppingMorphsNotInWorld (in category 'project state') -----
+ steppingMorphsNotInWorld
+ | all |
+ all := self allMorphs.
+ ^ self listOfSteppingMorphs select: [:m | (all includes: m) not]
+
+ "self currentWorld steppingMorphsNotInWorld do: [:m | m delete]"!
Item was added:
+ ----- Method: PasteUpMorph>>stopRunningAll (in category 'misc') -----
+ stopRunningAll
+ "Reset all ticking scripts to be paused. Triggered by user hitting STOP button"
+
+ self presenter allExtantPlayers do:
+ [:aPlayer |
+ aPlayer stopRunning].
+ self allScriptors do:
+ [:aScript | aScript pauseIfTicking].
+
+ self world updateStatusForAllScriptEditors!
Item was added:
+ ----- Method: PasteUpMorph>>stopStepping: (in category 'stepping') -----
+ stopStepping: aMorph
+ "Remove the given morph from the step list."
+
+ worldState stopStepping: aMorph
+ !
Item was added:
+ ----- Method: PasteUpMorph>>stopStepping:selector: (in category 'stepping') -----
+ stopStepping: aMorph selector: aSelector
+ "Remove the given morph from the step list."
+
+ worldState stopStepping: aMorph selector: aSelector
+ !
Item was added:
+ ----- Method: PasteUpMorph>>storeProjectsAsSegments (in category 'project') -----
+ storeProjectsAsSegments
+ "Force my sub-projects out to disk"
+
+ submorphs do:
+ [:sub |
+ (sub isSystemWindow)
+ ifTrue: [(sub model isKindOf: Project) ifTrue: [sub model storeSegment]]] "OK if was already out"!
Item was added:
+ ----- Method: PasteUpMorph>>thumbnailForPageSorter (in category 'misc') -----
+ thumbnailForPageSorter
+
+ ^ self cachedOrNewThumbnailFrom: BookPageThumbnailMorph new!
Item was added:
+ ----- Method: PasteUpMorph>>toggleAutoLineLayout (in category 'options') -----
+ toggleAutoLineLayout
+ "Toggle the auto-line-layout setting"
+
+ self autoLineLayout: self autoLineLayout not.
+ self autoLineLayout ifFalse: [self restoreBoundsOfSubmorphs].!
Item was added:
+ ----- Method: PasteUpMorph>>toggleClassicNavigatorIfAppropriate (in category 'world menu') -----
+ toggleClassicNavigatorIfAppropriate
+ "If appropriate, toggle the presence of classic navigator"
+
+ Preferences classicNavigatorEnabled ifTrue: [^ Preferences togglePreference: #showProjectNavigator]!
Item was added:
+ ----- Method: PasteUpMorph>>toggleIsPartsBin (in category 'options') -----
+ toggleIsPartsBin
+ "Not entirely happy with the openToDragNDrop not being directly manipulable etc, but still living with it for now."
+ self setPartsBinStatusTo: self isPartsBin not!
Item was added:
+ ----- Method: PasteUpMorph>>toggleMouseOverHalos (in category 'options') -----
+ toggleMouseOverHalos
+ wantsMouseOverHalos := self wantsMouseOverHalos not!
Item was added:
+ ----- Method: PasteUpMorph>>toggleResizeToFit (in category 'options') -----
+ toggleResizeToFit
+ "Toggle whether the receiver is set to resize-to-fit"
+
+ self vResizeToFit: self resizeToFit not!
Item was added:
+ ----- Method: PasteUpMorph>>toggleShowWorldMainDockingBar (in category 'menu & halo') -----
+ toggleShowWorldMainDockingBar
+ self project toggleShowWorldMainDockingBar!
Item was added:
+ ----- Method: PasteUpMorph>>transferMorphConverter (in category 'dropping/grabbing') -----
+ transferMorphConverter
+ ^self
+ valueOfProperty: #transferMorphConverter
+ ifAbsent: [ #yourself ]!
Item was added:
+ ----- Method: PasteUpMorph>>transferMorphConverter: (in category 'dropping/grabbing') -----
+ transferMorphConverter: aMessageSend
+ self
+ setProperty: #transferMorphConverter
+ toValue: aMessageSend!
Item was added:
+ ----- Method: PasteUpMorph>>transferRemoteServerFrom: (in category 'Nebraska') -----
+ transferRemoteServerFrom: aWorld
+ "Transfer the remote server which was associated with aWorld (if any) to the receiver"
+ | server |
+ (aWorld notNil and:[aWorld isMorph and:[aWorld isWorldMorph]]) ifFalse:[^self].
+ server := aWorld remoteServer.
+ server ifNotNil:[
+ self remoteServer: server.
+ server clients do:[:each| self addRemoteClient: each].
+ self primaryHand
+ userInitials: (aWorld primaryHand userInitials)
+ andPicture: (aWorld primaryHand userPicture).
+ aWorld primaryHand userInitials: '' andPicture: nil].
+ aWorld releaseRemoteServer.!
Item was added:
+ ----- Method: PasteUpMorph>>transformToShow: (in category 'menu & halo') -----
+ transformToShow: aRectangle
+
+ owner changeWorldBoundsToShow: aRectangle
+ !
Item was added:
+ ----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') -----
+ triggerClosingScripts
+ "If the receiver has any scripts set to run on closing, run them now"
+ | aPlayer |
+ (aPlayer := self player) ifNotNil:
+ [aPlayer runAllClosingScripts]!
Item was added:
+ ----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') -----
+ triggerOpeningScripts
+ "If the receiver has any scripts set to run on opening, run them now"
+ | aPlayer |
+ (aPlayer := self player) ifNotNil:
+ [aPlayer runAllOpeningScripts]!
Item was added:
+ ----- Method: PasteUpMorph>>undoOrRedoCommand (in category 'world menu') -----
+ undoOrRedoCommand
+ "Undo or redo the last command recorded in the world"
+
+ ^ self commandHistory undoOrRedoCommand!
Item was added:
+ ----- Method: PasteUpMorph>>unhideHiddenObjects (in category 'misc') -----
+ unhideHiddenObjects
+ self allMorphsDo:
+ [:m | m show]!
Item was added:
+ ----- Method: PasteUpMorph>>unusedMorphNameLike: (in category 'name') -----
+ unusedMorphNameLike: stem
+ "Answer a suitable name for a morph in this world, based on the stem provided"
+
+ | names |
+ names := self allKnownNames.
+ ^ Utilities keyLike: stem asString satisfying:
+ [:aName | (names includes: aName) not]!
Item was added:
+ ----- Method: PasteUpMorph>>updateStatusForAllScriptEditors (in category 'misc') -----
+ updateStatusForAllScriptEditors
+ self allScriptEditors do: [:anEditor | anEditor updateStatus]!
Item was added:
+ ----- Method: PasteUpMorph>>useRoundedCorners (in category 'accessing') -----
+ useRoundedCorners
+ "Somewhat special cased because we do have to fill Display for this"
+ super useRoundedCorners.
+ self == World ifTrue:[Display bits primFill: 0]. "done so that we *don't* get a flash"!
Item was added:
+ ----- Method: PasteUpMorph>>validateMouseEvent: (in category 'WiW support') -----
+ validateMouseEvent: evt
+
+ !
Item was added:
+ ----- Method: PasteUpMorph>>valueAtCursor (in category 'cursor') -----
+ valueAtCursor
+ "Answer the submorph of mine indexed by the value of my 'cursor' slot"
+
+ submorphs isEmpty ifTrue: [^ self presenter standardPlayer costume].
+ ^ (submorphs at: ((cursor truncated max: 1) min: submorphs size)) morphRepresented!
Item was added:
+ ----- Method: PasteUpMorph>>valueAtCursor: (in category 'cursor') -----
+ valueAtCursor: aMorph
+ submorphs isEmpty ifTrue: [^ self].
+ self rectifyCursor.
+ self replaceSubmorph: self valueAtCursor by: aMorph!
Item was added:
+ ----- Method: PasteUpMorph>>veryDeepCopyWith: (in category 'copying') -----
+ veryDeepCopyWith: deepCopier
+ "See storeDataOn:"
+
+ ^ self isWorldMorph
+ ifTrue: [self] "never copy the World"
+ ifFalse: [super veryDeepCopyWith: deepCopier]!
Item was added:
+ ----- Method: PasteUpMorph>>viewBox (in category 'project state') -----
+ viewBox
+ "This tortured workaround arises from a situation encountered
+ in which a PasteUpMorph was directliy lodged as a submorph
+ of another PasteUpMorph of identical size, with the former
+ bearing flaps but the latter being the world"
+ ^ worldState
+ ifNil: [super viewBox]
+ ifNotNil: [worldState viewBox]!
Item was added:
+ ----- Method: PasteUpMorph>>viewBox: (in category 'project state') -----
+ viewBox: newViewBox
+ "I am now displayed within newViewBox; react."
+
+ self isWorldMorph
+ ifTrue:
+ [(self viewBox isNil or: [self viewBox extent ~= newViewBox extent])
+ ifTrue: [worldState canvas: nil].
+ worldState viewBox: newViewBox].
+ super position: newViewBox topLeft.
+ fullBounds := bounds := newViewBox.
+
+ "Paragraph problem workaround; clear selections to avoid screen
+ droppings."
+ self flag: #arNote. "Probably unnecessary"
+ self isWorldMorph
+ ifTrue:
+ [worldState handsDo: [:hand | hand releaseKeyboardFocus].
+ self fullRepaintNeeded]!
Item was added:
+ ----- Method: PasteUpMorph>>viewingNormally (in category 'viewing') -----
+ viewingNormally
+ "Answer whether the receiver is being viewed normally, viz not in list-view or auto-line-layout"
+
+ ^ (self showingListView or: [self autoLineLayout == true]) not
+ !
Item was added:
+ ----- Method: PasteUpMorph>>wantsDirectionHandles (in category 'halos and balloon help') -----
+ wantsDirectionHandles
+
+ ^ super wantsDirectionHandles and: [self isWorldMorph not]!
Item was added:
+ ----- Method: PasteUpMorph>>wantsDropFiles: (in category 'event handling') -----
+ wantsDropFiles: anEvent
+ ^self isWorldMorph!
Item was added:
+ ----- Method: PasteUpMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
+ wantsDroppedMorph: aMorph event: evt
+ self isWorldMorph ifTrue:[^true]. "always"
+ self visible ifFalse: [^ false]. "will be a call to #hidden again very soon"
+ self dropEnabled ifFalse: [^ false].
+ ^ true!
Item was added:
+ ----- Method: PasteUpMorph>>wantsEasySelection (in category 'event handling') -----
+ wantsEasySelection
+ "Answer if the receiver want easy selection mode"
+ ^ Preferences easySelection!
Item was added:
+ ----- Method: PasteUpMorph>>wantsHaloFor: (in category 'halos and balloon help') -----
+ wantsHaloFor: aSubMorph
+ "Answer whether the receiver wishes for a mouse-over halo to be produced for aSubMorph"
+
+ ^ wantsMouseOverHalos == true and:
+ [self visible and:
+ [isPartsBin ~~ true and:
+ [self dropEnabled and:
+ [self isWorldMorph not or: [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]]
+
+ "The odd logic at the end of the above says...
+
+ * If we're an interior playfield, then if we're set up for mouseover halos, show em.
+ * If we're a World that's set up for mouseover halos, only show 'em if the putative
+ recipient is a SketchMorph.
+
+ This (old) logic was put in to suit a particular need in early e-toy days and seems rather strange now!!"!
Item was added:
+ ----- Method: PasteUpMorph>>wantsHaloFromClick (in category 'halos and balloon help') -----
+ wantsHaloFromClick
+ (owner isSystemWindow) ifTrue: [^ false].
+ self paintBoxOrNil ifNotNil: [^ false].
+ ^ true.
+ !
Item was added:
+ ----- Method: PasteUpMorph>>wantsKeyboardFocusFor: (in category 'event handling') -----
+ wantsKeyboardFocusFor: aSubmorph
+ aSubmorph inPartsBin ifTrue: [^ false].
+ aSubmorph wouldAcceptKeyboardFocus ifTrue: [ ^ true].
+ ^ super wantsKeyboardFocusFor: aSubmorph!
Item was added:
+ ----- Method: PasteUpMorph>>wantsMouseOverHalos (in category 'options') -----
+ wantsMouseOverHalos
+ ^ wantsMouseOverHalos == true!
Item was added:
+ ----- Method: PasteUpMorph>>wantsMouseOverHalos: (in category 'options') -----
+ wantsMouseOverHalos: aBoolean
+ wantsMouseOverHalos := aBoolean!
Item was added:
+ ----- Method: PasteUpMorph>>wantsWindowEvent: (in category 'event handling') -----
+ wantsWindowEvent: anEvent
+ ^self isWorldMorph or: [self windowEventHandler notNil]!
Item was added:
+ ----- Method: PasteUpMorph>>windowEvent: (in category 'event handling') -----
+ windowEvent: anEvent
+ self windowEventHandler
+ ifNotNil: [^self windowEventHandler windowEvent: anEvent].
+
+ anEvent type == #windowClose
+ ifTrue: [
+ ^Preferences eToyFriendly
+ ifTrue: [ProjectNavigationMorph basicNew quitSqueak]
+ ifFalse: [TheWorldMenu basicNew quitSession]].
+ !
Item was added:
+ ----- Method: PasteUpMorph>>windowEventHandler (in category 'event handling') -----
+ windowEventHandler
+ "This is a class variable so it is global to all projects and does not get saved"
+ ^WindowEventHandler!
Item was added:
+ ----- Method: PasteUpMorph>>windowEventHandler: (in category 'event handling') -----
+ windowEventHandler: anObject
+ "This is a class variable so it is global to all projects and does not get saved"
+ WindowEventHandler := anObject
+ !
Item was added:
+ ----- Method: PasteUpMorph>>world (in category 'structure') -----
+ world
+ worldState ifNil: [^super world].
+ ^self!
Item was added:
+ ----- Method: PasteUpMorph>>yellowButtonClickOnDesktopWithEvent: (in category 'world menu') -----
+ yellowButtonClickOnDesktopWithEvent: evt
+ "Put up either the personalized menu or the world menu when
+ the user clicks on the morphic desktop with the yellow button.
+ The preference 'personalizedWorldMenu' governs which one
+ is used"
+ | aMenu |
+ Preferences personalizedWorldMenu
+ ifTrue: [aMenu := MenuMorph new defaultTarget: self.
+ Preferences personalizeUserMenu: aMenu.
+ aMenu addLine.
+ aMenu
+ add: 'personalize...' translated
+ target: Preferences
+ action: #letUserPersonalizeMenu]
+ ifFalse: [aMenu := self buildWorldMenu: evt.
+ aMenu addTitle: 'World' translated].
+ aMenu popUpEvent: evt in: self!
Item was added:
+ Morph subclass: #PianoRollNoteMorph
+ instanceVariableNames: 'trackIndex indexInTrack hitLoc editMode selected notePlaying'
+ classVariableNames: 'SoundPlaying'
+ poolDictionaries: ''
+ category: 'Morphic-Sound'!
+
+ !PianoRollNoteMorph commentStamp: '<historical>' prior: 0!
+ A PianoRollNoteMorph is drawn as a simple mroph, but it carries the necessary state to locate its source sound event via its owner (a PianorRollScoreMorph) and the score therein. Simple editing of pitch and time placement is provided here.!
Item was added:
+ ----- Method: PianoRollNoteMorph>>deselect (in category 'selecting') -----
+ deselect
+
+ selected ifFalse: [^ self].
+ self changed.
+ selected := false.
+ !
Item was added:
+ ----- Method: PianoRollNoteMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ selected
+ ifTrue: [aCanvas frameAndFillRectangle: self fullBounds fillColor: color borderWidth: 1 borderColor: Color black]
+ ifFalse: [aCanvas fillRectangle: self bounds color: color].
+ !
Item was added:
+ ----- Method: PianoRollNoteMorph>>editPitch: (in category 'editing') -----
+ editPitch: evt
+
+ | mk note |
+ mk := owner midiKeyForY: evt cursorPoint y.
+ note := (owner score tracks at: trackIndex) at: indexInTrack.
+ note midiKey = mk ifTrue: [^ self].
+ note midiKey: mk.
+ self playSound: (self soundOfDuration: 999.0).
+ self position: self position x @ ((owner yForMidiKey: mk) - 1)
+ !
Item was added:
+ ----- Method: PianoRollNoteMorph>>fullBounds (in category 'layout') -----
+ fullBounds
+
+ selected
+ ifTrue: [^ bounds expandBy: 1]
+ ifFalse: [^ bounds]!
Item was added:
+ ----- Method: PianoRollNoteMorph>>gridToNextQuarter (in category 'editing') -----
+ gridToNextQuarter
+
+ owner score gridTrack: trackIndex toQuarter: 1 at: indexInTrack.
+ owner rebuildFromScore!
Item was added:
+ ----- Method: PianoRollNoteMorph>>gridToPrevQuarter (in category 'editing') -----
+ gridToPrevQuarter
+
+ owner score gridTrack: trackIndex toQuarter: -1 at: indexInTrack.
+ owner rebuildFromScore!
Item was added:
+ ----- Method: PianoRollNoteMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ owner scorePlayer isPlaying not!
Item was added:
+ ----- Method: PianoRollNoteMorph>>indexInTrack (in category 'accessing') -----
+ indexInTrack
+
+ ^ indexInTrack!
Item was added:
+ ----- Method: PianoRollNoteMorph>>invokeNoteMenu: (in category 'menu') -----
+ invokeNoteMenu: evt
+ "Invoke the note's edit menu."
+
+ | menu |
+ menu := MenuMorph new defaultTarget: self.
+ menu addList:
+ #(('grid to next quarter' gridToNextQuarter)
+ ('grid to prev quarter' gridToPrevQuarter)).
+
+ menu popUpEvent: evt in: self world.
+ !
Item was added:
+ ----- Method: PianoRollNoteMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+
+ hitLoc := evt cursorPoint.
+ editMode := nil.
+ owner submorphsDo:
+ [:m | (m isKindOf: PianoRollNoteMorph) ifTrue: [m deselect]].
+ selected := true.
+ self changed.
+ owner selection: (Array with: trackIndex with: indexInTrack with: indexInTrack).
+ self playSound!
Item was added:
+ ----- Method: PianoRollNoteMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ | delta offsetEvt |
+ editMode isNil
+ ifTrue:
+ ["First movement determines edit mode"
+
+ ((delta := evt cursorPoint - hitLoc) dist: 0 @ 0) <= 2
+ ifTrue: [^self "No significant movement yet."].
+ delta x abs > delta y abs
+ ifTrue:
+ [delta x > 0
+ ifTrue:
+ ["Horizontal drag"
+
+ editMode := #selectNotes]
+ ifFalse:
+ [self playSound: nil.
+ offsetEvt := evt copy setCursorPoint: evt cursorPoint + (20 @ 0).
+ self invokeNoteMenu: offsetEvt]]
+ ifFalse: [editMode := #editPitch "Vertical drag"]].
+ editMode == #editPitch ifTrue: [self editPitch: evt].
+ editMode == #selectNotes ifTrue: [self selectNotes: evt]!
Item was added:
+ ----- Method: PianoRollNoteMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+
+ self playSound: nil!
Item was added:
+ ----- Method: PianoRollNoteMorph>>noteInScore (in category 'note playing') -----
+ noteInScore
+
+ ^ (owner score tracks at: trackIndex) at: indexInTrack
+ !
Item was added:
+ ----- Method: PianoRollNoteMorph>>noteOfDuration: (in category 'note playing') -----
+ noteOfDuration: duration
+
+ | note |
+ note := self noteInScore.
+ ^ (owner scorePlayer instrumentForTrack: trackIndex)
+ soundForMidiKey: note midiKey
+ dur: duration
+ loudness: (note velocity asFloat / 127.0)
+ !
Item was added:
+ ----- Method: PianoRollNoteMorph>>playSound (in category 'note playing') -----
+ playSound
+ "This STARTS a single long sound. It must be stopped by playing another or nil."
+
+ ^ self playSound: (self soundOfDuration: 999.0)!
Item was added:
+ ----- Method: PianoRollNoteMorph>>playSound: (in category 'note playing') -----
+ playSound: aSoundOrNil
+
+ SoundPlaying ifNotNil: [SoundPlaying stopGracefully].
+ SoundPlaying := aSoundOrNil.
+ SoundPlaying ifNotNil: [SoundPlaying play].!
Item was added:
+ ----- Method: PianoRollNoteMorph>>select (in category 'selecting') -----
+ select
+
+ selected ifTrue: [^ self].
+ selected := true.
+ self changed!
Item was added:
+ ----- Method: PianoRollNoteMorph>>selectFrom: (in category 'selecting') -----
+ selectFrom: selection
+ (trackIndex = selection first and:
+ [indexInTrack >= (selection second) and: [indexInTrack <= (selection third)]])
+ ifTrue: [selected ifFalse: [self select]]
+ ifFalse: [selected ifTrue: [self deselect]]!
Item was added:
+ ----- Method: PianoRollNoteMorph>>selectNotes: (in category 'selecting') -----
+ selectNotes: evt
+
+ | lastMorph oldEnd saveOwner |
+ saveOwner := owner.
+ (owner autoScrollForX: evt cursorPoint x) ifTrue:
+ ["If scroll talkes place I will be deleted and my x-pos will become invalid."
+ owner := saveOwner.
+ bounds := bounds withLeft: (owner xForTime: self noteInScore time)].
+ oldEnd := owner selection last.
+ (owner notesInRect: (evt cursorPoint x @ owner top corner: owner bottomRight))
+ do: [:m | m trackIndex = trackIndex ifTrue: [m deselect]].
+ self select. lastMorph := self.
+ (owner notesInRect: (self left @ owner top corner: evt cursorPoint x @ owner bottom))
+ do: [:m | m trackIndex = trackIndex ifTrue: [m select. lastMorph := m]].
+ owner selection: (Array with: trackIndex with: indexInTrack with: lastMorph indexInTrack).
+ lastMorph indexInTrack ~= oldEnd ifTrue:
+ ["Play last note as selection grows or shrinks"
+ owner ifNotNil: [lastMorph playSound]]
+ !
Item was added:
+ ----- Method: PianoRollNoteMorph>>selected (in category 'selecting') -----
+ selected
+
+ ^ selected!
Item was added:
+ ----- Method: PianoRollNoteMorph>>soundOfDuration: (in category 'note playing') -----
+ soundOfDuration: duration
+
+ | sound |
+ sound := MixedSound new.
+ sound add: (self noteOfDuration: duration)
+ pan: (owner scorePlayer panForTrack: trackIndex)
+ volume: owner scorePlayer overallVolume *
+ (owner scorePlayer volumeForTrack: trackIndex).
+ ^ sound reset
+ !
Item was added:
+ ----- Method: PianoRollNoteMorph>>trackIndex (in category 'accessing') -----
+ trackIndex
+
+ ^ trackIndex!
Item was added:
+ ----- Method: PianoRollNoteMorph>>trackIndex:indexInTrack: (in category 'initialization') -----
+ trackIndex: ti indexInTrack: i
+
+ trackIndex := ti.
+ indexInTrack := i.
+ selected := false!
Item was added:
+ AlignmentMorph subclass: #PluggableButtonMorph
+ instanceVariableNames: 'model label getStateSelector actionSelector getLabelSelector getMenuSelector shortcutCharacter askBeforeChanging triggerOnMouseDown offColor onColor feedbackColor showSelectionFeedback allButtons arguments argumentsProvider argumentsSelector style'
+ classVariableNames: 'GradientButton RoundedButtonCorners'
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
+
+ !PluggableButtonMorph commentStamp: '<historical>' prior: 0!
+ A PluggableButtonMorph is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are:
+
+ getStateSelector fetch a boolean value from the model
+ actionSelector invoke this button's action on the model
+ getLabelSelector fetch this button's lable from the model
+ getMenuSelector fetch a pop-up menu for this button from the model
+
+ Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false.
+
+ The model informs its view(s) of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector.
+
+ If the actionSelector takes one or more arguments, then the following are relevant:
+ arguments A list of arguments to provide when the actionSelector is called.
+ argumentsProvider The object that is sent the argumentSelector to obtain arguments, if dynamic
+ argumentsSelector The message sent to the argumentProvider to obtain the arguments.
+
+ Options:
+ askBeforeChanging have model ask user before allowing a change that could lose edits
+ triggerOnMouseDown do this button's action on mouse down (vs. up) transition
+ shortcutCharacter a place to record an optional shortcut key
+ !
Item was added:
+ ----- Method: PluggableButtonMorph class>>example (in category 'example') -----
+ example
+ "PluggableButtonMorph example openInWorld"
+
+ | s1 s2 s3 b1 b2 b3 row switchClass |
+ switchClass := Smalltalk at: #Switch ifAbsent: [^self inform: 'MVC class Switch not present'].
+ s1 := switchClass new.
+ s2 := switchClass new turnOn.
+ s3 := switchClass new.
+ s2 onAction: [s3 turnOff].
+ s3 onAction: [s2 turnOff].
+ b1 := (PluggableButtonMorph on: s1 getState: #isOn action: #switch) label: 'S1'.
+ b2 := (PluggableButtonMorph on: s2 getState: #isOn action: #turnOn) label: 'S2'.
+ b3 := (PluggableButtonMorph on: s3 getState: #isOn action: #turnOn) label: 'S3'.
+ b1
+ hResizing: #spaceFill;
+ vResizing: #spaceFill.
+ b2
+ hResizing: #spaceFill;
+ vResizing: #spaceFill.
+ b3
+ hResizing: #spaceFill;
+ vResizing: #spaceFill.
+
+ row := AlignmentMorph newRow
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ addAllMorphs: (Array with: b1 with: b2 with: b3);
+ extent: 120 at 35.
+ ^ row
+ !
Item was added:
+ ----- Method: PluggableButtonMorph class>>gradientButton (in category 'preferences') -----
+ gradientButton
+ <preference: 'gradientButton'
+ category: 'windows'
+ description: 'If true, buttons will have a gradient look.'
+ type: #Boolean>
+ ^ GradientButton ifNil: [ true ]!
Item was added:
+ ----- Method: PluggableButtonMorph class>>gradientButton: (in category 'preferences') -----
+ gradientButton: aBoolean
+
+ GradientButton := aBoolean.!
Item was added:
+ ----- Method: PluggableButtonMorph class>>on: (in category 'instance creation') -----
+ on: anObject
+
+ ^ self on: anObject getState: #isOn action: #switch
+ !
Item was added:
+ ----- Method: PluggableButtonMorph class>>on:getState:action: (in category 'instance creation') -----
+ on: anObject getState: getStateSel action: actionSel
+
+ ^ self new
+ on: anObject
+ getState: getStateSel
+ action: actionSel
+ label: nil
+ menu: nil
+ !
Item was added:
+ ----- Method: PluggableButtonMorph class>>on:getState:action:label: (in category 'instance creation') -----
+ on: anObject getState: getStateSel action: actionSel label: labelSel
+
+ ^ self new
+ on: anObject
+ getState: getStateSel
+ action: actionSel
+ label: labelSel
+ menu: nil
+ !
Item was added:
+ ----- Method: PluggableButtonMorph class>>on:getState:action:label:menu: (in category 'instance creation') -----
+ on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel
+
+ ^ self new
+ on: anObject
+ getState: getStateSel
+ action: actionSel
+ label: labelSel
+ menu: menuSel
+ !
Item was added:
+ ----- Method: PluggableButtonMorph class>>roundedButtonCorners (in category 'preferences') -----
+ roundedButtonCorners
+ <preference: 'Rounded Button Corners'
+ category: 'windows'
+ description: 'Governs whether pluggable buttons in system windows should be rounded'
+ type: #Boolean>
+ ^ RoundedButtonCorners ifNil: [ true ]!
Item was added:
+ ----- Method: PluggableButtonMorph class>>roundedButtonCorners: (in category 'preferences') -----
+ roundedButtonCorners: aBoolean
+
+ RoundedButtonCorners := aBoolean.
+ World invalidRect: World bounds from: World.!
Item was added:
+ ----- Method: PluggableButtonMorph>>action: (in category 'accessing') -----
+ action: aSymbol
+ "Set actionSelector to be the action defined by aSymbol."
+
+ actionSelector := aSymbol.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>actionSelector (in category 'accessing') -----
+ actionSelector
+ "Answer the receiver's actionSelector"
+
+ ^ actionSelector!
Item was added:
+ ----- Method: PluggableButtonMorph>>arguments: (in category 'arguments') -----
+ arguments: args
+ "If the receiver takes argument(s) that are static, they can be filled by calling this. If its argument(s) are to be dynamically determined, then use an argumentProvider and argumentSelector instead"
+
+ arguments := args!
Item was added:
+ ----- Method: PluggableButtonMorph>>argumentsProvider:argumentsSelector: (in category 'arguments') -----
+ argumentsProvider: anObject argumentsSelector: aSelector
+ "Set the argument provider and selector"
+
+ argumentsProvider := anObject.
+ argumentsSelector := aSelector!
Item was added:
+ ----- Method: PluggableButtonMorph>>askBeforeChanging (in category 'accessing') -----
+ askBeforeChanging
+
+ ^ askBeforeChanging
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>askBeforeChanging: (in category 'accessing') -----
+ askBeforeChanging: aBoolean
+ "If this preference is turned on, then give the model an opportunity to ask the user before accepting a change that might cause unaccepted edits to be lost."
+
+ askBeforeChanging := aBoolean.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>browseAllImplementorsOfActionSelector (in category 'browse') -----
+ browseAllImplementorsOfActionSelector
+ SystemNavigation default browseAllImplementorsOf: actionSelector localTo: model class!
Item was added:
+ ----- Method: PluggableButtonMorph>>buildDebugMenu: (in category 'browse') -----
+ buildDebugMenu: aHandMorph
+ | aMenu |
+ aMenu := super buildDebugMenu: aHandMorph.
+ aMenu addLine.
+ aMenu add: 'implementors of' translated target: self action: #browseAllImplementorsOfActionSelector.
+ ^ aMenu!
Item was added:
+ ----- Method: PluggableButtonMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 1!
Item was added:
+ ----- Method: PluggableButtonMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color gray: 0.7!
Item was added:
+ ----- Method: PluggableButtonMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | cc gradient borderColor fill |
+ cc := self color.
+ cc isTransparent ifTrue:[cc := Color gray: 0.9].
+ self enabled ifFalse:[cc := Color lightGray].
+ cc brightness > 0.9 ifTrue:[cc := cc adjustBrightness: 0.9 - cc brightness].
+ showSelectionFeedback ifTrue:[
+ borderColor := cc muchDarker.
+ gradient := GradientFillStyle ramp: {
+ 0.0 -> cc muchDarker.
+ 0.1-> (cc adjustBrightness: -0.2).
+ 0.5 -> cc.
+ 0.9-> (cc adjustBrightness: -0.1).
+ 1 -> cc muchDarker}.
+ cc := cc muchDarker.
+ ] ifFalse:[
+ borderColor := Color lightGray.
+ gradient := GradientFillStyle ramp: {
+ 0.0 -> Color white.
+ 0.1-> (cc adjustBrightness: 0.05).
+ 0.6 -> (cc darker)}.
+ ].
+ gradient origin: bounds topLeft.
+ gradient direction: 0 at self height.
+
+ PluggableButtonMorph gradientButton
+ ifFalse: [fill := SolidFillStyle color: cc]
+ ifTrue: [fill := gradient].
+
+ ^ self wantsRoundedCorners
+ ifTrue: [aCanvas
+ frameAndFillRoundRect: bounds
+ radius: self class preferredCornerRadius
+ fillStyle: fill
+ borderWidth: 1
+ borderColor: borderColor]
+ ifFalse: [aCanvas
+ frameAndFillRectangle: self innerBounds
+ fillColor: fill asColor
+ borderWidth: 1
+ borderColor: borderColor darker;
+ fillRectangle: (self innerBounds insetBy: 1)
+ fillStyle: fill]!
Item was added:
+ ----- Method: PluggableButtonMorph>>enabled (in category 'accessing') -----
+ enabled
+ ^true!
Item was added:
+ ----- Method: PluggableButtonMorph>>feedbackColor: (in category 'accessing') -----
+ feedbackColor: aColor
+ "Set the color of this button's selection feedback border."
+
+ feedbackColor := aColor.
+ self changed.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>getMenu: (in category 'private') -----
+ getMenu: shiftPressed
+ "Answer the menu for this button, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."
+
+ | menu |
+ getMenuSelector isNil ifTrue: [^nil].
+ menu := MenuMorph new defaultTarget: model.
+ getMenuSelector numArgs = 1
+ ifTrue: [^model perform: getMenuSelector with: menu].
+ getMenuSelector numArgs = 2
+ ifTrue:
+ [^model
+ perform: getMenuSelector
+ with: menu
+ with: shiftPressed].
+ ^self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'!
Item was added:
+ ----- Method: PluggableButtonMorph>>getModelState (in category 'private') -----
+ getModelState
+ "Answer the result of sending the receiver's model the getStateSelector message."
+
+ ^ getStateSelector
+ ifNil: [false]
+ ifNotNil: [model perform: getStateSelector]!
Item was added:
+ ----- Method: PluggableButtonMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ true
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>handlesMouseOver: (in category 'event handling') -----
+ handlesMouseOver: evt
+
+ ^ true!
Item was added:
+ ----- Method: PluggableButtonMorph>>handlesMouseOverDragging: (in category 'event handling') -----
+ handlesMouseOverDragging: evt
+
+ ^ true!
Item was added:
+ ----- Method: PluggableButtonMorph>>initialize (in category 'initialize-release') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self listDirection: #topToBottom.
+ self hResizing: #shrinkWrap.
+ "<--so naked buttons work right"
+ self vResizing: #shrinkWrap.
+ self wrapCentering: #center;
+ cellPositioning: #topCenter.
+ self borderStyle: BorderStyle thinGray.
+ model := nil.
+ label := nil.
+ getStateSelector := nil.
+ actionSelector := nil.
+ getLabelSelector := nil.
+ getMenuSelector := nil.
+ shortcutCharacter := nil.
+ askBeforeChanging := false.
+ triggerOnMouseDown := false.
+ onColor := self color darker.
+ offColor := self color.
+ feedbackColor := Color red.
+ showSelectionFeedback := false.
+ allButtons := nil.
+ argumentsProvider := nil.
+ argumentsSelector := nil.
+ self extent: 20 @ 15!
Item was added:
+ ----- Method: PluggableButtonMorph>>invokeMenu: (in category 'private') -----
+ invokeMenu: evt
+ "Invoke my menu in response to the given event."
+ | menu |
+ menu := self getMenu: evt shiftPressed.
+ menu ifNotNil: [menu popUpEvent: evt in: self world]!
Item was added:
+ ----- Method: PluggableButtonMorph>>label (in category 'accessing') -----
+ label
+ "Answer the DisplayObject used as this button's label."
+
+ ^ label
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>label: (in category 'accessing') -----
+ label: aStringOrTextOrMorph
+ self label: aStringOrTextOrMorph font: Preferences standardButtonFont !
Item was added:
+ ----- Method: PluggableButtonMorph>>label:font: (in category 'accessing') -----
+ label: aStringOrTextOrMorph font: aFont
+ "Label this button with the given string or morph."
+
+ | r |
+ self removeAllMorphs.
+ "nest label in a row for centering"
+ r := AlignmentMorph newRow
+ borderWidth: 0;
+ layoutInset: 0;
+ color: Color transparent;
+ hResizing: #shrinkWrap;
+ vResizing: #spaceFill;
+ wrapCentering: #center; cellPositioning: #leftCenter.
+ aStringOrTextOrMorph isMorph
+ ifTrue: [
+ label := aStringOrTextOrMorph.
+ r addMorph: aStringOrTextOrMorph]
+ ifFalse: [
+ label := aStringOrTextOrMorph asString.
+ r addMorph: (StringMorph contents: label font: aFont)].
+ self addMorph: r.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>model: (in category 'accessing') -----
+ model: anObject
+ "Set my model and make me me a dependent of the given object."
+
+ model ifNotNil: [model removeDependent: self].
+ anObject ifNotNil: [anObject addDependent: self].
+ model := anObject.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "Details: If this button is triggered on mouse down or the event is the menu gesture, handle it immediately. Otherwise, make a list of buttons (including the receiver) for mouseMove feedback. This allows a simple radio-button effect among the button submorphs of a given morph."
+
+ allButtons := nil.
+ evt yellowButtonPressed ifTrue: [^ self invokeMenu: evt].
+ triggerOnMouseDown
+ ifTrue: [self performAction]
+ ifFalse: [
+ allButtons := owner submorphs select: [:m | m class = self class].
+ self updateFeedbackForEvt: evt].
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>mouseEnter: (in category 'event handling') -----
+ mouseEnter: evt
+
+ "0.09375 is exact in floating point so no cumulative rounding error will occur"
+ self color: (self color adjustBrightness: -0.09375)!
Item was added:
+ ----- Method: PluggableButtonMorph>>mouseLeave: (in category 'event handling') -----
+ mouseLeave: evt
+
+ "0.09375 is exact in floating point so no cumulative rounding error will occur"
+ self color: (self color adjustBrightness: 0.09375).
+ self update: nil!
Item was added:
+ ----- Method: PluggableButtonMorph>>mouseLeaveDragging: (in category 'event handling') -----
+ mouseLeaveDragging: evt
+
+ self mouseLeave: evt!
Item was added:
+ ----- Method: PluggableButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+
+ allButtons ifNil: [^ self].
+ allButtons do: [:m | m updateFeedbackForEvt: evt].
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+
+ showSelectionFeedback := false.
+ borderColor isColor ifFalse:[borderColor := #raised].
+ allButtons ifNil: [^ self].
+ allButtons do: [:m |
+ (m containsPoint: evt cursorPoint) ifTrue: [m performAction]].
+ allButtons := nil.
+ self changed.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>offColor (in category 'accessing') -----
+ offColor
+ ^ offColor
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>offColor: (in category 'accessing') -----
+ offColor: colorWhenOff
+ "Set the fill colors to be used when this button is off."
+
+ self onColor: onColor offColor: colorWhenOff
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>on:getState:action:label:menu: (in category 'initialize-release') -----
+ on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel
+
+ self model: anObject.
+ getStateSelector := getStateSel.
+ actionSelector := actionSel.
+ getLabelSelector := labelSel.
+ getMenuSelector := menuSel.
+ self update: labelSel.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>onColor:offColor: (in category 'accessing') -----
+ onColor: colorWhenOn offColor: colorWhenOff
+ "Set the fill colors to be used when this button is on/off."
+
+ onColor := colorWhenOn.
+ offColor := colorWhenOff.
+ self update: nil.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>performAction (in category 'accessing') -----
+ performAction
+ "Inform the model that this button has been pressed. Sent by the controller when this button is pressed. If the button's actionSelector takes any arguments, they are obtained dynamically by sending the argumentSelector to the argumentsProvider"
+
+ askBeforeChanging ifTrue: [model okToChange ifFalse: [^ self]].
+ actionSelector ifNotNil:
+ [actionSelector numArgs = 0
+ ifTrue:
+ [model perform: actionSelector]
+ ifFalse:
+ [argumentsProvider ifNotNil:
+ [arguments := argumentsProvider perform: argumentsSelector].
+ model perform: actionSelector withArguments: arguments]]!
Item was added:
+ ----- Method: PluggableButtonMorph>>shortcutCharacter (in category 'accessing') -----
+ shortcutCharacter
+ "Return the Character to be used as a shortcut to turn on this switch, or nil if this switch doesn't have a keyboard shortcut."
+
+ ^ shortcutCharacter
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>shortcutCharacter: (in category 'accessing') -----
+ shortcutCharacter: aCharacter
+ "Set the character to be used as a keyboard shortcut for turning on this switch."
+
+ shortcutCharacter := aCharacter.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>style (in category 'accessing') -----
+ style
+ "Treat aSymbol as a hint to modify the button appearance."
+ ^style
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>style: (in category 'accessing') -----
+ style: aSymbol
+ "Use aSymbol as a hint to modify the button appearance."
+ style := aSymbol
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>triggerOnMouseDown (in category 'accessing') -----
+ triggerOnMouseDown
+
+ ^ triggerOnMouseDown
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>triggerOnMouseDown: (in category 'accessing') -----
+ triggerOnMouseDown: aBoolean
+ "If this preference is turned on, then trigger my action immediately when the mouse goes down."
+
+ triggerOnMouseDown := aBoolean.
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>update: (in category 'updating') -----
+ update: aParameter
+
+ getLabelSelector ifNotNil: [
+ aParameter == getLabelSelector ifTrue: [
+ self label: (model perform: getLabelSelector)]].
+ self getModelState
+ ifTrue: [self color: onColor]
+ ifFalse: [self color: offColor].
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>updateFeedbackForEvt: (in category 'events') -----
+ updateFeedbackForEvt: evt
+
+ | newState |
+ newState := self containsPoint: evt cursorPoint.
+ newState = showSelectionFeedback ifFalse: [
+ borderColor isColor
+ ifTrue:[showSelectionFeedback := newState]
+ ifFalse:[borderColor := newState ifTrue:[#inset] ifFalse:[#raised]].
+ self changed].
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ model := deepCopier references at: model ifAbsent: [model].
+ !
Item was added:
+ ----- Method: PluggableButtonMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ "model := model. Weakly copied"
+ label := label veryDeepCopyWith: deepCopier.
+ "getStateSelector := getStateSelector. a Symbol"
+ "actionSelector := actionSelector. a Symbol"
+ "getLabelSelector := getLabelSelector. a Symbol"
+ "getMenuSelector := getMenuSelector. a Symbol"
+ shortcutCharacter := shortcutCharacter veryDeepCopyWith: deepCopier.
+ askBeforeChanging := askBeforeChanging veryDeepCopyWith: deepCopier.
+ triggerOnMouseDown := triggerOnMouseDown veryDeepCopyWith: deepCopier.
+ offColor := offColor veryDeepCopyWith: deepCopier.
+ onColor := onColor veryDeepCopyWith: deepCopier.
+ feedbackColor := feedbackColor veryDeepCopyWith: deepCopier.
+ showSelectionFeedback := showSelectionFeedback veryDeepCopyWith: deepCopier.
+ allButtons := nil. "a cache"
+ arguments := arguments veryDeepCopyWith: deepCopier.
+ argumentsProvider := argumentsProvider veryDeepCopyWith: deepCopier.
+ "argumentsSelector := argumentsSelector. a Symbol"
+ style := style. "a Symbol"!
Item was added:
+ ----- Method: PluggableButtonMorph>>wantsRoundedCorners (in category 'rounding') -----
+ wantsRoundedCorners
+ "If the button is intended to invoke a menu for selection, provide a visual
+ distinction by inverting the rounded corners attribute."
+
+ ^ (self class roundedButtonCorners or: [super wantsRoundedCorners])
+ xor: style == #menuButton!
Item was added:
+ Canvas subclass: #PluggableCanvas
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !PluggableCanvas commentStamp: '<historical>' prior: 0!
+ An abstract canvas which modifies the behavior of an underlying canvas in some way. Subclasses should implement apply:, which takes a one argument block and an actual canvas to draw on. See apply: for the specific definition.!
Item was added:
+ ----- Method: PluggableCanvas>>apply: (in category 'private') -----
+ apply: aBlock
+ "evaluate aBlock with a canvas to do a drawing command on. See implementors for examples"!
Item was added:
+ ----- Method: PluggableCanvas>>balloonFillOval:fillStyle:borderWidth:borderColor: (in category 'canvas methods') -----
+ balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
+
+ self apply: [ :c |
+ c balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
+ ]!
Item was added:
+ ----- Method: PluggableCanvas>>balloonFillRectangle:fillStyle: (in category 'canvas methods') -----
+ balloonFillRectangle: aRectangle fillStyle: aFillStyle
+
+ self apply: [ :c | c balloonFillRectangle: aRectangle fillStyle: aFillStyle ]!
Item was added:
+ ----- Method: PluggableCanvas>>clipBy:during: (in category 'drawing-support') -----
+ clipBy: newClipRect during: aBlock
+ self apply: [ :c |
+ c clipBy: newClipRect during: aBlock ]!
Item was added:
+ ----- Method: PluggableCanvas>>clipRect (in category 'accessing') -----
+ clipRect
+ | innerClipRect |
+ self apply: [ :c |
+ innerClipRect := c clipRect ].
+ ^innerClipRect!
Item was added:
+ ----- Method: PluggableCanvas>>contentsOfArea:into: (in category 'accessing') -----
+ contentsOfArea: aRectangle into: aForm
+ self apply: [ :c |
+ c contentsOfArea: aRectangle into: aForm ].
+ ^aForm!
Item was added:
+ ----- Method: PluggableCanvas>>drawPolygon:color:borderWidth:borderColor: (in category 'drawing-polygons') -----
+ drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
+ self apply: [ :c |
+ c drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc ]!
Item was added:
+ ----- Method: PluggableCanvas>>drawString:from:to:in:font:color: (in category 'drawing-text') -----
+ drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
+ self apply: [ :clippedCanvas |
+ clippedCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]!
Item was added:
+ ----- Method: PluggableCanvas>>extent (in category 'accessing') -----
+ extent
+
+ self apply: [ :c | ^c extent ].
+ !
Item was added:
+ ----- Method: PluggableCanvas>>fillOval:color:borderWidth:borderColor: (in category 'drawing-ovals') -----
+ fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
+ self apply: [ :clippedCanvas |
+ clippedCanvas fillOval: r color: c borderWidth: borderWidth borderColor: borderColor ]!
Item was added:
+ ----- Method: PluggableCanvas>>fillOval:fillStyle:borderWidth:borderColor: (in category 'drawing-ovals') -----
+ fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
+ "Fill the given oval."
+ self shadowColor ifNotNil:
+ [^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
+ (aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
+ self flag: #fixThis.
+ ^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc].
+ (aFillStyle isSolidFill) ifTrue:[
+ ^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
+ "Use a BalloonCanvas instead"
+ self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc!
Item was added:
+ ----- Method: PluggableCanvas>>fillRectangle:fillStyle: (in category 'drawing-rectangles') -----
+ fillRectangle: aRectangle fillStyle: aFillStyle
+
+ | pattern |
+
+ self shadowColor ifNotNil: [^self fillRectangle: aRectangle color: self shadowColor].
+
+ (aFillStyle isKindOf: InfiniteForm) ifTrue: [
+ ^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
+ ].
+
+ aFillStyle isSolidFill ifTrue:[ ^self fillRectangle: aRectangle color: aFillStyle asColor].
+
+ "We have a very special case for filling with infinite forms"
+ (aFillStyle isBitmapFill and:[aFillStyle origin = (0 at 0)]) ifTrue:[
+ pattern := aFillStyle form.
+ (aFillStyle direction = (pattern width @ 0)
+ and:[aFillStyle normal = (0 at pattern height)]) ifTrue:[
+ "Can use an InfiniteForm"
+ ^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
+ ].
+ "Use a BalloonCanvas instead"
+ self balloonFillRectangle: aRectangle fillStyle: aFillStyle.
+ !
Item was added:
+ ----- Method: PluggableCanvas>>flush (in category 'initialization') -----
+ flush
+ self apply: [ :c |
+ c flush ]!
Item was added:
+ ----- Method: PluggableCanvas>>flushDisplay (in category 'other') -----
+ flushDisplay
+ self apply: [ :c |
+ c flushDisplay ]!
Item was added:
+ ----- Method: PluggableCanvas>>forceToScreen: (in category 'other') -----
+ forceToScreen: rect
+
+ self apply: [ :c |
+ c forceToScreen: rect ]!
Item was added:
+ ----- Method: PluggableCanvas>>frameAndFillRectangle:fillColor:borderWidth:borderColor: (in category 'drawing-rectangles') -----
+ frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
+ self apply: [ :c |
+ c frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor ]!
Item was added:
+ ----- Method: PluggableCanvas>>frameAndFillRoundRect:radius:fillStyle:borderWidth:borderColor: (in category 'drawing-rectangles') -----
+ frameAndFillRoundRect: aRectangle radius: cornerRadius fillStyle: fillStyle borderWidth: bw borderColor: bc
+ self apply: [ :c |
+ c frameAndFillRoundRect: aRectangle radius: cornerRadius fillStyle: fillStyle borderWidth: bw borderColor: bc ]!
Item was added:
+ ----- Method: PluggableCanvas>>image:at:sourceRect:rule: (in category 'private') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule
+ self apply: [ :c |
+ c image: aForm at: aPoint sourceRect: sourceRect rule: rule ]!
Item was added:
+ ----- Method: PluggableCanvas>>infiniteFillRectangle:fillStyle: (in category 'canvas methods') -----
+ infiniteFillRectangle: aRectangle fillStyle: aFillStyle
+
+ self apply: [ :c | c infiniteFillRectangle: aRectangle fillStyle: aFillStyle ]!
Item was added:
+ ----- Method: PluggableCanvas>>line:to:brushForm: (in category 'drawing') -----
+ line: pt1 to: pt2 brushForm: brush
+ self apply: [ :c |
+ c line: pt1 to: pt2 brushForm: brush ]!
Item was added:
+ ----- Method: PluggableCanvas>>line:to:width:color: (in category 'drawing') -----
+ line: pt1 to: pt2 width: w color: c
+ self apply: [ :clippedCanvas |
+ clippedCanvas line: pt1 to: pt2 width: w color: c ]!
Item was added:
+ ----- Method: PluggableCanvas>>origin (in category 'accessing') -----
+ origin
+
+ self apply: [ :c | ^c origin ].
+ !
Item was added:
+ ----- Method: PluggableCanvas>>paintImage:at: (in category 'drawing-images') -----
+ paintImage: aForm at: aPoint
+ self apply: [ :c |
+ c paintImage: aForm at: aPoint ]!
Item was added:
+ ----- Method: PluggableCanvas>>paintImage:at:sourceRect: (in category 'drawing-images') -----
+ paintImage: aForm at: aPoint sourceRect: sourceRect
+ self apply: [ :c |
+ c paintImage: aForm at: aPoint sourceRect: sourceRect ]!
Item was added:
+ ----- Method: PluggableCanvas>>paragraph:bounds:color: (in category 'drawing') -----
+ paragraph: paragraph bounds: bounds color: color
+ self apply: [ :c |
+ c paragraph: paragraph bounds: bounds color: color ]!
Item was added:
+ ----- Method: PluggableCanvas>>render: (in category 'drawing') -----
+ render: anObject
+ self apply: [ :c |
+ c render: anObject ]!
Item was added:
+ ----- Method: PluggableCanvas>>shadowColor: (in category 'accessing') -----
+ shadowColor: color
+ self apply: [ :c |
+ c shadowColor: color ]!
Item was added:
+ ----- Method: PluggableCanvas>>showAt:invalidRects: (in category 'canvas methods') -----
+ showAt: pt invalidRects: updateRects
+ self apply: [ :c |
+ c showAt: pt invalidRects: updateRects ]!
Item was added:
+ ----- Method: PluggableCanvas>>stencil:at:sourceRect:color: (in category 'drawing-images') -----
+ stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
+ self apply: [ :c |
+ c stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor ]!
Item was added:
+ ----- Method: PluggableCanvas>>transformBy:clippingTo:during:smoothing: (in category 'drawing-support') -----
+ transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
+
+ self apply: [ :clippedCanvas |
+ clippedCanvas transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize ]!
Item was added:
+ ----- Method: PluggableCanvas>>translateBy:clippingTo:during: (in category 'other') -----
+ translateBy: aPoint clippingTo: aRect during: aBlock
+ self apply: [ :clippedCanvas |
+ clippedCanvas translateBy: aPoint clippingTo: aRect during: aBlock ]!
Item was added:
+ ----- Method: PluggableCanvas>>translateBy:during: (in category 'drawing-support') -----
+ translateBy: delta during: aBlock
+ self apply: [ :clippedCanvas |
+ clippedCanvas translateBy: delta during: aBlock ]!
Item was added:
+ ----- Method: PluggableFileList>>morphicOpenLabel:in: (in category '*Morphic-FileList') -----
+ morphicOpenLabel: aString in: aWorld
+ "Open a view of an instance of me."
+ "PluggableFileList new morphicOpenLabel: 'foo' in: World"
+ | windowMorph volListMorph templateMorph fileListMorph leftButtonMorph middleButtonMorph rightButtonMorph |
+
+ self directory: directory.
+ windowMorph := (SystemWindow labelled: aString) model: self.
+
+ volListMorph := PluggableListMorph on: self
+ list: #volumeList
+ selected: #volumeListIndex
+ changeSelected: #volumeListIndex:
+ menu: #volumeMenu:.
+ volListMorph autoDeselect: false.
+ windowMorph addMorph: volListMorph frame: (0 at 0 corner: 0.4 at 0.5625).
+
+ templateMorph := PluggableTextMorph on: self
+ text: #pattern
+ accept: #pattern:.
+ templateMorph askBeforeDiscardingEdits: false.
+ windowMorph addMorph: templateMorph frame: (0 at 0.5625 corner: 0.4 at 0.75).
+
+ fileListMorph := PluggableListMorph on: self
+ list: #fileList
+ selected: #fileListIndex
+ changeSelected: #fileListIndex:
+ menu: #fileListMenu:.
+
+ windowMorph addMorph: fileListMorph frame: (0.4 at 0 corner: 1.0 at 0.75).
+
+ leftButtonMorph := PluggableButtonMorph
+ on: self
+ getState: #leftButtonState
+ action: #leftButtonPressed.
+ leftButtonMorph
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ label: 'Cancel';
+ onColor: Color red offColor: Color red;
+ feedbackColor: Color orange;
+ borderWidth: 3.
+
+ middleButtonMorph := PluggableButtonMorph
+ on: self
+ getState: nil
+ action: nil.
+ middleButtonMorph
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ label: prompt;
+ onColor: Color lightYellow offColor: Color lightYellow;
+ feedbackColor: Color lightYellow;
+ borderWidth: 1.
+
+ rightButtonMorph := PluggableButtonMorph
+ on: self
+ getState: #rightButtonState
+ action: #rightButtonPressed.
+ rightButtonMorph
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ label: 'Accept';
+ onColor: Color green offColor: Color lightYellow;
+ feedbackColor: Color black;
+ borderWidth: (self canAccept ifTrue: [3] ifFalse: [1]).
+ "self canAccept ifFalse: [rightButtonMorph controller: NoController new]."
+
+ windowMorph
+ addMorph: leftButtonMorph frame: (0 at 0.75 corner: 0.25 at 1.0);
+ addMorph: middleButtonMorph frame: (0.25 at 0.75 corner: 0.75 at 1.0);
+ addMorph: rightButtonMorph frame: (0.75 at 0.75 corner: 1.0 at 1.0).
+
+ self changed: #getSelectionSel.
+
+ windowMorph openInWorld: aWorld.
+ [windowMorph model notNil]
+ whileTrue: [aWorld doOneCycle].
+ ^self result
+ !
Item was added:
+ ListItemWrapper subclass: #PluggableListItemWrapper
+ instanceVariableNames: 'string getContentsSelector getStringSelector hasContentsSelector'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
+
+ !PluggableListItemWrapper commentStamp: 'ar 10/14/2003 23:51' prior: 0!
+ luggableListItemWrapper makes it more easy for clients to use hierarchical lists. Rather than having to write a subclass of ListItemWrapper, a PluggableListItemWrapper can be used to provide the appropriate information straight from the model:
+ string - an explicit string representation (contrary to the 'item' which contains any kind of object)
+ getStringSelector - a message invoked to retrieve the sting representation of its item dynamically from its model (when a constant representation is undesirable)
+ hasContentsSelector - a message invoked in the model to answer whether the item has any children or not.
+ getContentsSelector - a message invoked in the model to retrieve the contents for its item.
+
+ All callback selectors can have zero, one or two arguments with the item and the wrapper as first and second argument.!
Item was added:
+ ----- Method: PluggableListItemWrapper>>asString (in category 'accessing') -----
+ asString
+ string ifNotNil:[^string].
+ getStringSelector ifNil:[^super asString].
+ ^self sendToModel: getStringSelector
+ !
Item was added:
+ ----- Method: PluggableListItemWrapper>>contents (in category 'accessing') -----
+ contents
+ getContentsSelector ifNil:[^#()].
+ ^self sendToModel: getContentsSelector.!
Item was added:
+ ----- Method: PluggableListItemWrapper>>getContentsSelector (in category 'accessing') -----
+ getContentsSelector
+ ^getContentsSelector!
Item was added:
+ ----- Method: PluggableListItemWrapper>>getContentsSelector: (in category 'accessing') -----
+ getContentsSelector: aSymbol
+ self validateSelector: aSymbol.
+ getContentsSelector := aSymbol.!
Item was added:
+ ----- Method: PluggableListItemWrapper>>getStringSelector (in category 'accessing') -----
+ getStringSelector
+ ^getStringSelector!
Item was added:
+ ----- Method: PluggableListItemWrapper>>getStringSelector: (in category 'accessing') -----
+ getStringSelector: aSymbol
+ self validateSelector: aSymbol.
+ getStringSelector := aSymbol.!
Item was added:
+ ----- Method: PluggableListItemWrapper>>hasContents (in category 'accessing') -----
+ hasContents
+ hasContentsSelector ifNil:[^super hasContents].
+ ^self sendToModel: hasContentsSelector
+ !
Item was added:
+ ----- Method: PluggableListItemWrapper>>hasContentsSelector (in category 'accessing') -----
+ hasContentsSelector
+ ^hasContentsSelector!
Item was added:
+ ----- Method: PluggableListItemWrapper>>hasContentsSelector: (in category 'accessing') -----
+ hasContentsSelector: aSymbol
+ self validateSelector: aSymbol.
+ hasContentsSelector := aSymbol.!
Item was added:
+ ----- Method: PluggableListItemWrapper>>printOn: (in category 'printing') -----
+ printOn: aStream
+ super printOn: aStream.
+ aStream nextPut:$(; nextPutAll: self asString; nextPut:$).!
Item was added:
+ ----- Method: PluggableListItemWrapper>>sendToModel: (in category 'private') -----
+ sendToModel: aSelector
+ aSelector numArgs = 0
+ ifTrue:[^model perform: aSelector].
+ aSelector numArgs = 1
+ ifTrue:[^model perform: aSelector with: item].
+ aSelector numArgs = 2
+ ifTrue:[^model perform: aSelector with: item with: self].!
Item was added:
+ ----- Method: PluggableListItemWrapper>>string (in category 'accessing') -----
+ string
+ ^string!
Item was added:
+ ----- Method: PluggableListItemWrapper>>string: (in category 'accessing') -----
+ string: aString
+ string := aString!
Item was added:
+ ----- Method: PluggableListItemWrapper>>validateSelector: (in category 'private') -----
+ validateSelector: aSymbol
+ (aSymbol numArgs between: 0 and: 2) ifFalse:[^self error: 'Invalid pluggable selector'].!
Item was added:
+ ScrollPane subclass: #PluggableListMorph
+ instanceVariableNames: 'list getListSelector getListSizeSelector getListElementSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes lastClickTime doubleClickSelector handlesBasicKeys potentialDropRow hoverRow listMorph hScrollRangeCache keystrokePreviewSelector priorSelection getIconSelector'
+ classVariableNames: 'ClearFilterAutomatically FilterableLists HighlightHoveredRow MenuRequestUpdatesSelection'
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
+
+ !PluggableListMorph commentStamp: 'cmm 8/21/2011 23:37' prior: 0!
+ When a PluggableListMorph is in focus, type in a letter (or several letters quickly) to go to the next item that begins with that letter (if FilterableLists is false).
+
+ Special keys (up, down, home, etc.) are also supported.!
Item was added:
+ ----- Method: PluggableListMorph class>>clearFilterAutomatically (in category 'preferences') -----
+ clearFilterAutomatically
+ <preference: 'Filterable Lists Clear Automatically'
+ category: 'scrolling'
+ description: 'When using the Filterable Lists option, if this option is also selected, then the filter will be cleared as soon as the list loses keyboard focus.'
+ type: #Boolean>
+ ^ ClearFilterAutomatically ifNil: [ true ]!
Item was added:
+ ----- Method: PluggableListMorph class>>clearFilterAutomatically: (in category 'preferences') -----
+ clearFilterAutomatically: aBoolean
+ ClearFilterAutomatically := aBoolean!
Item was added:
+ ----- Method: PluggableListMorph class>>filterableLists (in category 'preferences') -----
+ filterableLists
+ <preference: 'Filterable Lists'
+ category: 'scrolling'
+ description: 'When true, using the keyboard on a list will filter it rather than scroll. Pressing enter clears the filter and keeps the filtered selection. Backspace clears the filter and returns to the prior selection.'
+ type: #Boolean>
+ ^ FilterableLists ifNil: [ true ]!
Item was added:
+ ----- Method: PluggableListMorph class>>filterableLists: (in category 'preferences') -----
+ filterableLists: aBoolean
+ "When true, using the keyboard on a list will filter it rather than scroll. Pressing enter clears the filter and keeps the filtered selection. Backspace clears the filter and returns to the prior selection."
+ FilterableLists := aBoolean!
Item was added:
+ ----- Method: PluggableListMorph class>>highlightHoveredRow (in category 'preferences') -----
+ highlightHoveredRow
+
+ <preference: 'Highlight Hovered Row in Lists'
+ category: #Morphic
+ description: 'Indicate, which row will be affected before any further iteraction takes place.'
+ type: #Boolean>
+ ^ HighlightHoveredRow ifNil: [true]!
Item was added:
+ ----- Method: PluggableListMorph class>>highlightHoveredRow: (in category 'preferences') -----
+ highlightHoveredRow: aBoolean
+
+ HighlightHoveredRow := aBoolean.!
Item was added:
+ ----- Method: PluggableListMorph class>>menuRequestUpdatesSelection (in category 'preferences') -----
+ menuRequestUpdatesSelection
+
+ <preference: 'Menu request updates list/tree selection'
+ category: #Morphic
+ description: 'When invoking a menu, this will for the current selection by default. If the mouse cursor it at a different location, however, this preference will update the selection before showing the menu if enabled.'
+ type: #Boolean>
+ ^ MenuRequestUpdatesSelection ifNil: [ false ]!
Item was added:
+ ----- Method: PluggableListMorph class>>menuRequestUpdatesSelection: (in category 'preferences') -----
+ menuRequestUpdatesSelection: aBoolean
+
+ MenuRequestUpdatesSelection := aBoolean.!
Item was added:
+ ----- Method: PluggableListMorph class>>on:list:selected:changeSelected: (in category 'instance creation') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel
+ "Create a 'pluggable' list view on the given model parameterized by the given message selectors."
+
+ ^ self new
+ on: anObject
+ list: getListSel
+ selected: getSelectionSel
+ changeSelected: setSelectionSel
+ menu: nil
+ keystroke: #arrowKey:from: "default"!
Item was added:
+ ----- Method: PluggableListMorph class>>on:list:selected:changeSelected:menu: (in category 'instance creation') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel
+ "Create a 'pluggable' list view on the given model parameterized by the given message selectors."
+
+ ^ self new
+ on: anObject
+ list: getListSel
+ selected: getSelectionSel
+ changeSelected: setSelectionSel
+ menu: getMenuSel
+ keystroke: #arrowKey:from: "default"
+ !
Item was added:
+ ----- Method: PluggableListMorph class>>on:list:selected:changeSelected:menu:keystroke: (in category 'instance creation') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
+ "Create a 'pluggable' list view on the given model parameterized by the given message selectors."
+
+ ^ self new
+ on: anObject
+ list: getListSel
+ selected: getSelectionSel
+ changeSelected: setSelectionSel
+ menu: getMenuSel
+ keystroke: keyActionSel
+ !
Item was added:
+ ----- Method: PluggableListMorph>>acceptDroppingMorph:event: (in category 'drag and drop') -----
+ acceptDroppingMorph: aMorph event: evt
+ "This message is sent when a morph is dropped onto a morph that has
+ agreed to accept the dropped morph by responding 'true' to the
+ wantsDroppedMorph:Event: message. The default implementation just
+ adds the given morph to the receiver."
+ "Here we let the model do its work."
+
+ self model
+ acceptDroppingMorph: aMorph
+ event: evt
+ inMorph: self.
+ self resetPotentialDropRow.
+ evt hand releaseMouseFocus: self.
+ Cursor normal show.
+ !
Item was added:
+ ----- Method: PluggableListMorph>>addCustomMenuItems:hand: (in category 'menus') -----
+ addCustomMenuItems: aMenu hand: aHandMorph
+ "Add halo menu items to be handled by the invoking hand. The halo menu is invoked by clicking on the menu-handle of the receiver's halo."
+
+ super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addLine.
+ aMenu add: 'list font...' translated target: self action: #setListFont.
+ aMenu add: 'copy list to clipboard' translated target: self action: #copyListToClipboard.
+ aMenu add: 'copy selection to clipboard' translated target: self action: #copySelectionToClipboard!
Item was added:
+ ----- Method: PluggableListMorph>>allSubmorphNamesDo: (in category 'submorphs-accessing') -----
+ allSubmorphNamesDo: nameBlock
+ "Assume list morphs do not have named parts -- saves MUCH time"
+
+ ^ self!
Item was added:
+ ----- Method: PluggableListMorph>>autoDeselect: (in category 'initialization') -----
+ autoDeselect: trueOrFalse
+ "Enable/disable autoDeselect (see class comment)"
+ autoDeselect := trueOrFalse.!
Item was added:
+ ----- Method: PluggableListMorph>>basicKeyPressed: (in category 'model access') -----
+ basicKeyPressed: aChar
+ | milliseconds slowKeyStroke listSize newSelectionIndex oldSelectionIndex startIndex |
+ oldSelectionIndex := newSelectionIndex := self getCurrentSelectionIndex.
+ listSize := self getListSize.
+ listSize = 0 ifTrue: [ ^self flash ].
+ milliseconds := Time millisecondClockValue.
+ slowKeyStroke := (Time
+ milliseconds: milliseconds
+ since: lastKeystrokeTime) > (self class filterableLists ifTrue: [500] ifFalse: [ 300 ]).
+ lastKeystrokeTime := milliseconds.
+ slowKeyStroke
+ ifTrue:
+ [ self class filterableLists ifTrue: [ self hasFilter ifFalse: [ priorSelection := self modelIndexFor: self selectionIndex] ].
+ "forget previous keystrokes and search in following elements"
+ lastKeystrokes := aChar asLowercase asString.
+ newSelectionIndex := newSelectionIndex \\ listSize + 1.
+ self class filterableLists ifTrue: [ list := self getFullList ] ]
+ ifFalse: [ "append quick keystrokes but don't move selection if it still matches"
+ lastKeystrokes := lastKeystrokes , aChar asLowercase asString.
+ newSelectionIndex := newSelectionIndex max: 1 ].
+ "No change if model is locked"
+ model okToChange ifFalse: [ ^ self ].
+ self class filterableLists
+ ifTrue:
+ [ self
+ filterList ;
+ updateList.
+ newSelectionIndex := self modelIndexFor: 1 ]
+ ifFalse:
+ [ startIndex := newSelectionIndex.
+ listSize := self getListSize.
+ [ (self getListItem: newSelectionIndex) asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes ] whileFalse:
+ [ (newSelectionIndex := newSelectionIndex \\ listSize + 1) = startIndex ifTrue: [ ^ self flash"Not in list." ] ].
+ newSelectionIndex = oldSelectionIndex ifTrue: [ ^ self flash ] ].
+ (self hasFilter and: [(self getCurrentSelectionIndex = newSelectionIndex) not]) ifTrue:
+ [self changeModelSelection: newSelectionIndex]!
Item was added:
+ ----- Method: PluggableListMorph>>bottomVisibleRowIndex (in category 'accessing') -----
+ bottomVisibleRowIndex
+ ^ self rowAtLocation: self bottomLeft+(3 at 3 negated)!
Item was added:
+ ----- Method: PluggableListMorph>>canBeEncroached (in category 'testing') -----
+ canBeEncroached
+ "Answer whether my bottom edge can be encroached by horizontal smart-splitter. If my list is larger than my outermost containing window, go ahead and report true since moving a splitter will never allow my entire list to be displayed. In that case go ahead and be encroachable to allow lower truncated text-panes to be exposed, but leave a reasonable height (70) to ensure at least few items are displayed."
+ ^ self height > 24 and:
+ [ | outermostContainer |
+ outermostContainer := self outermostMorphThat:
+ [ : e | e owner = World ].
+ listMorph height + 8 < self height or:
+ [ outermostContainer notNil and: [ listMorph height > (outermostContainer height / 1.2) and: [ self height > 70 ] ] ] ]!
Item was added:
+ ----- Method: PluggableListMorph>>changeModelSelection: (in category 'model access') -----
+ changeModelSelection: anInteger
+ " Change the model's selected item index to be anInteger. Enable the pre selection highlight. Step the World forward to let the pre selection highlight take effect. "
+
+ self rowAboutToBecomeSelected: (self uiIndexFor: anInteger).
+ World displayWorldSafely.
+ setIndexSelector ifNotNil: [
+ model perform: setIndexSelector with: anInteger ].!
Item was added:
+ ----- Method: PluggableListMorph>>charactersOccluded (in category 'geometry') -----
+ charactersOccluded
+ "Answer the number of characters occluded in my #visibleList by my right edge."
+ | listIndex | listIndex:=0.
+ ^ self visibleList
+ inject: 0
+ into:
+ [ : sum : each | | eachString totalWidth indexOfLastVisible iconWidth |
+ totalWidth:=0.
+ eachString := each asString "withBlanksTrimmed".
+ iconWidth := (self iconAt: (listIndex := listIndex+1)) ifNil:[0] ifNotNil: [ : icon | icon width+2 ].
+ indexOfLastVisible := ((1 to: eachString size)
+ detect:
+ [ : stringIndex | (totalWidth:=totalWidth+(self font widthOf: (eachString at: stringIndex))) >
+ (self width -
+ (scrollBar
+ ifNil: [ 0 ]
+ ifNotNil: [ scrollBar width ]) - iconWidth) ]
+ ifNone: [ eachString size + 1 ]) - 1.
+ sum + (eachString size - indexOfLastVisible) ]!
Item was added:
+ ----- Method: PluggableListMorph>>commandKeyTypedIntoMenu: (in category 'model access') -----
+ commandKeyTypedIntoMenu: evt
+ "The user typed a command-key into a menu which has me as its command-key handler"
+
+ ^ self modifierKeyPressed: evt keyCharacter!
Item was added:
+ ----- Method: PluggableListMorph>>copyListToClipboard (in category 'menus') -----
+ copyListToClipboard
+ "Copy my items to the clipboard as a multi-line string"
+
+ | stream |
+ stream := WriteStream on: (String new: self getList size * 40).
+ list do: [:ea | stream nextPutAll: ea asString] separatedBy: [stream nextPut: Character cr].
+ Clipboard clipboardText: stream contents!
Item was added:
+ ----- Method: PluggableListMorph>>copySelectionToClipboard (in category 'menus') -----
+ copySelectionToClipboard
+ "Copy my selected item to the clipboard as a string"
+
+ self selection
+ ifNotNil:
+ [Clipboard clipboardText: self selection asString]
+ ifNil:
+ [self flash]!
Item was added:
+ ----- Method: PluggableListMorph>>deriveHScrollRange (in category 'scroll cache') -----
+ deriveHScrollRange
+
+ | unadjustedRange totalRange |
+ (list isNil or: [list isEmpty])
+ ifTrue:[hScrollRangeCache := Array with: 0 with: 0 with: 0 with: 0 with: 0 ]
+ ifFalse:[
+ unadjustedRange := self listMorph hUnadjustedScrollRange.
+ totalRange := unadjustedRange + self hExtraScrollRange + self hMargin.
+ hScrollRangeCache := Array
+ with: totalRange
+ with: unadjustedRange
+ with: list size
+ with: list first
+ with: list last .
+ ].
+ !
Item was added:
+ ----- Method: PluggableListMorph>>doubleClick: (in category 'events') -----
+ doubleClick: event
+ | index |
+ doubleClickSelector ifNil: [^super doubleClick: event].
+ index := self rowAtLocation: event position.
+ index = 0 ifTrue: [^super doubleClick: event].
+ "selectedMorph ifNil: [self setSelectedMorph: aMorph]."
+ ^ self model perform: doubleClickSelector!
Item was added:
+ ----- Method: PluggableListMorph>>doubleClick:onItem: (in category 'obsolete') -----
+ doubleClick: event onItem: aMorph
+ self removeObsoleteEventHandlers.!
Item was added:
+ ----- Method: PluggableListMorph>>doubleClickSelector: (in category 'initialization') -----
+ doubleClickSelector: aSymbol
+ doubleClickSelector := aSymbol!
Item was added:
+ ----- Method: PluggableListMorph>>extent: (in category 'geometry') -----
+ extent: newExtent
+ super extent: newExtent.
+
+ "Change listMorph's bounds to the new width. It is either the size
+ of the widest list item, or the size of self, whatever is bigger"
+ self listMorph width: ((self width max: listMorph hUnadjustedScrollRange) + 20).
+ !
Item was added:
+ ----- Method: PluggableListMorph>>filterList (in category 'filtering') -----
+ filterList
+ self hasFilter
+ ifTrue:
+ [ | frontMatching substringMatching newList |
+ self indicateFiltered.
+ frontMatching := OrderedCollection new.
+ substringMatching := OrderedCollection new.
+ list withIndexDo:
+ [ : each : n | | foundPos |
+ foundPos := each asString
+ findString: lastKeystrokes
+ startingAt: 1
+ caseSensitive: false.
+ foundPos = 1
+ ifTrue: [ frontMatching add: each ]
+ ifFalse:
+ [ foundPos = 0 ifFalse: [ substringMatching add: each ] ] ].
+ newList := frontMatching , substringMatching.
+ newList
+ ifEmpty:
+ [ lastKeystrokes := lastKeystrokes allButLast: 1.
+ self
+ flash ;
+ filterList ]
+ ifNotEmpty: [ list := newList ] ]
+ ifFalse: [ self indicateUnfiltered ]!
Item was added:
+ ----- Method: PluggableListMorph>>font (in category 'initialization') -----
+ font
+
+ ^ self listMorph font
+ !
Item was added:
+ ----- Method: PluggableListMorph>>font: (in category 'initialization') -----
+ font: aFontOrNil
+ self listMorph font: aFontOrNil.
+ !
Item was added:
+ ----- Method: PluggableListMorph>>getCurrentSelectionIndex (in category 'model access') -----
+ getCurrentSelectionIndex
+ "Answer the index of the current selection."
+
+ getIndexSelector ifNil: [^0].
+ ^model perform: getIndexSelector!
Item was added:
+ ----- Method: PluggableListMorph>>getFullList (in category 'model access') -----
+ getFullList
+ "The full, unfiltered list."
+ ^ model perform: getListSelector!
Item was added:
+ ----- Method: PluggableListMorph>>getIconSelector: (in category 'initialization') -----
+ getIconSelector: aSymbol
+ getIconSelector := aSymbol!
Item was added:
+ ----- Method: PluggableListMorph>>getList (in category 'model access') -----
+ getList
+ "Answer the list to be displayed. Caches the returned list in the 'list' ivar"
+ getListSelector == nil ifTrue: [ ^ Array empty ].
+ list := self getFullList.
+ self class filterableLists ifTrue: [ self filterList ].
+ ^ list ifNil: [ Array empty ]!
Item was added:
+ ----- Method: PluggableListMorph>>getListElementSelector: (in category 'initialization') -----
+ getListElementSelector: aSymbol
+ "specify a selector that can be used to obtain a single element in the underlying list"
+ getListElementSelector == aSymbol ifTrue:[^self].
+ getListElementSelector := aSymbol.
+ list := nil. "this cache will not be updated if getListElementSelector has been specified, so go ahead and remove it"!
Item was added:
+ ----- Method: PluggableListMorph>>getListItem: (in category 'model access') -----
+ getListItem: index
+ "get the index-th item in the displayed list"
+ getListElementSelector ifNotNil: [ ^(model perform: getListElementSelector with: index) asStringOrText ].
+ list ifNotNil: [ ^list at: index ].
+ ^self getList at: index!
Item was added:
+ ----- Method: PluggableListMorph>>getListSelector (in category 'selection') -----
+ getListSelector
+ ^ getListSelector!
Item was added:
+ ----- Method: PluggableListMorph>>getListSelector: (in category 'initialization') -----
+ getListSelector: sel
+ "Set the receiver's getListSelector as indicated, and trigger a recomputation of the list"
+ self
+ setGetListSelector: sel ;
+ changed ;
+ updateList!
Item was added:
+ ----- Method: PluggableListMorph>>getListSize (in category 'model access') -----
+ getListSize
+ "return the current number of items in the displayed list"
+ getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ].
+ ^self getList size!
Item was added:
+ ----- Method: PluggableListMorph>>getListSizeSelector: (in category 'initialization') -----
+ getListSizeSelector: aSymbol
+ "specify a selector that can be used to specify the list's size"
+ getListSizeSelector := aSymbol!
Item was added:
+ ----- Method: PluggableListMorph>>getMenu: (in category 'menu') -----
+ getMenu: shiftKeyState
+ "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."
+
+ | aMenu |
+ aMenu := super getMenu: shiftKeyState.
+ aMenu ifNotNil: [aMenu commandKeyHandler: self].
+ ^ aMenu!
Item was added:
+ ----- Method: PluggableListMorph>>hExtraScrollRange (in category 'scrolling') -----
+ hExtraScrollRange
+ "Return the amount of extra blank space to include to the right of the scroll content."
+ ^5
+ !
Item was added:
+ ----- Method: PluggableListMorph>>hTotalScrollRange (in category 'scroll cache') -----
+ hTotalScrollRange
+ "Return the entire scrolling range."
+
+ self resetHScrollRangeIfNecessary.
+
+ ^hScrollRangeCache first
+ !
Item was added:
+ ----- Method: PluggableListMorph>>hUnadjustedScrollRange (in category 'scroll cache') -----
+ hUnadjustedScrollRange
+ "Return the entire scrolling range."
+
+ self resetHScrollRangeIfNecessary.
+
+ ^hScrollRangeCache second
+ !
Item was added:
+ ----- Method: PluggableListMorph>>handleBasicKeys: (in category 'events') -----
+ handleBasicKeys: aBoolean
+ "set whether the list morph should handle basic keys like arrow keys, or whether everything should be passed to the model"
+ handlesBasicKeys := aBoolean!
Item was added:
+ ----- Method: PluggableListMorph>>handleMouseMove: (in category 'events-processing') -----
+ handleMouseMove: anEvent
+ "Reimplemented because we really want #mouseMove when a morph is dragged around"
+ anEvent wasHandled ifTrue:[^self]. "not interested"
+ self hoverRow: (self rowAtLocation: anEvent position).
+ (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
+ anEvent wasHandled: true.
+ self mouseMove: anEvent.
+ (self handlesMouseStillDown: anEvent) ifTrue:[
+ "Step at the new location"
+ self startStepping: #handleMouseStillDown:
+ at: Time millisecondClockValue
+ arguments: {anEvent copy resetHandlerFields}
+ stepTime: 1].
+ !
Item was added:
+ ----- Method: PluggableListMorph>>handlesBasicKeys (in category 'events') -----
+ handlesBasicKeys
+ " if ya don't want the list to automatically handle non-modifier key
+ (excluding shift key) input, return false"
+ ^ handlesBasicKeys ifNil: [ true ]!
Item was added:
+ ----- Method: PluggableListMorph>>handlesMouseOverDragging: (in category 'event handling') -----
+ handlesMouseOverDragging: evt
+ ^self dropEnabled!
Item was added:
+ ----- Method: PluggableListMorph>>hasFilter (in category 'filtering') -----
+ hasFilter
+ ^ lastKeystrokes isEmptyOrNil not!
Item was added:
+ ----- Method: PluggableListMorph>>highlightSelection (in category 'drawing') -----
+ highlightSelection!
Item was added:
+ ----- Method: PluggableListMorph>>highlightSelector (in category 'accessing') -----
+ highlightSelector
+ ^self valueOfProperty: #highlightSelector!
Item was added:
+ ----- Method: PluggableListMorph>>highlightSelector: (in category 'accessing') -----
+ highlightSelector: aSelector
+ self setProperty: #highlightSelector toValue: aSelector.
+ self updateList!
Item was added:
+ ----- Method: PluggableListMorph>>hoverItem (in category 'accessing') -----
+ hoverItem
+
+ ^ self hoverRow = 0
+ ifTrue: [nil]
+ ifFalse: [self getListItem: self hoverRow]!
Item was added:
+ ----- Method: PluggableListMorph>>hoverRow (in category 'accessing') -----
+ hoverRow
+
+ ^ hoverRow ifNil: [0]!
Item was added:
+ ----- Method: PluggableListMorph>>hoverRow: (in category 'accessing') -----
+ hoverRow: anInteger
+
+ hoverRow = anInteger ifTrue: [^ self].
+
+ hoverRow ifNotNil: [self listMorph rowChanged: hoverRow].
+ hoverRow := anInteger.
+ hoverRow ifNotNil: [self listMorph rowChanged: hoverRow].!
Item was added:
+ ----- Method: PluggableListMorph>>iconAt: (in category 'model access') -----
+ iconAt: anInteger
+
+ | index |
+ index := (self hasFilter and: [list notNil])
+ ifTrue: [self getFullList indexOf: (list at: anInteger ifAbsent: [^nil])]
+ ifFalse: [anInteger].
+ ^ getIconSelector ifNotNil: [model perform: getIconSelector with: index]!
Item was added:
+ ----- Method: PluggableListMorph>>indicateFiltered (in category 'filtering') -----
+ indicateFiltered
+ self color: Color red muchLighter muchLighter!
Item was added:
+ ----- Method: PluggableListMorph>>indicateUnfiltered (in category 'filtering') -----
+ indicateUnfiltered
+ self color: Color white!
Item was added:
+ ----- Method: PluggableListMorph>>initForKeystrokes (in category 'initialization') -----
+ initForKeystrokes
+ lastKeystrokeTime := 0.
+ lastKeystrokes := ''!
Item was added:
+ ----- Method: PluggableListMorph>>initialize (in category 'geometry') -----
+ initialize
+ super initialize.
+ self minWidth: 38!
Item was added:
+ ----- Method: PluggableListMorph>>installModelIn: (in category 'debug and other') -----
+ installModelIn: aWorld
+ "No special inits for new components"
+ ^ self!
Item was added:
+ ----- Method: PluggableListMorph>>isPluggableListMorph (in category 'drawing') -----
+ isPluggableListMorph
+ ^ true!
Item was added:
+ ----- Method: PluggableListMorph>>itemFromPoint: (in category 'accessing') -----
+ itemFromPoint: aPoint
+ "Return the list element (morph) at the given point or nil if outside"
+ | ptY |
+ scroller hasSubmorphs ifFalse:[^nil].
+ (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil].
+ ptY := (scroller firstSubmorph point: aPoint from: self) y.
+ "note: following assumes that submorphs are vertical, non-overlapping, and ordered"
+ scroller firstSubmorph top > ptY ifTrue:[^nil].
+ scroller lastSubmorph bottom < ptY ifTrue:[^nil].
+ "now use binary search"
+ ^scroller
+ findSubmorphBinary:[:item|
+ (item top <= ptY and:[item bottom >= ptY])
+ ifTrue:[0] "found"
+ ifFalse:[ (item top + item bottom // 2) > ptY ifTrue:[-1] ifFalse:[1]]]!
Item was added:
+ ----- Method: PluggableListMorph>>itemSelectedAmongMultiple: (in category 'model access') -----
+ itemSelectedAmongMultiple: index
+ "return whether the index-th row is selected. Always false in PluggableListMorph, but sometimes true in PluggableListMorphOfMany"
+ ^false!
Item was added:
+ ----- Method: PluggableListMorph>>keyStroke: (in category 'event handling') -----
+ keyStroke: event
+ "Process keys
+ The model is allowed to preview all keystrokes. If it's not interested:
+ specialKeys are things like up, down, etc. ALWAYS HANDLED
+ modifierKeys are regular characters either 1) accompanied with ctrl,
+ cmd or 2) any character if the list doesn't want to handle basic
+ keys (handlesBasicKeys returns false)
+ basicKeys are any characters"
+
+ | aChar aSpecialKey |
+ (self previewKeystroke: event)
+ ifTrue: [^ self].
+ (self scrollByKeyboard: event)
+ ifTrue: [^ self].
+
+ aChar := event keyCharacter.
+
+ (aSpecialKey := aChar asciiValue) < 32
+ ifTrue: [^ self specialKeyPressed: aSpecialKey].
+
+ (event anyModifierKeyPressed or: [self handlesBasicKeys not])
+ ifTrue: [^ self modifierKeyPressed: aChar].
+
+ ^ self basicKeyPressed: aChar!
Item was added:
+ ----- Method: PluggableListMorph>>keyboardFocusChange: (in category 'event handling') -----
+ keyboardFocusChange: aBoolean
+ "The message is sent to a morph when its keyboard focus changes.
+ The given argument indicates that the receiver is gaining (versus losing) the keyboard focus.
+ In this case, all we need to do is to redraw border feedback"
+ aBoolean ifFalse: [
+ self hoverRow: nil.
+ self class clearFilterAutomatically ifTrue:
+ [ self hasFilter ifTrue:
+ [ self
+ removeFilter ;
+ updateList ] ] ].
+
+ super keyboardFocusChange: aBoolean.!
Item was added:
+ ----- Method: PluggableListMorph>>keystrokeActionSelector: (in category 'initialization') -----
+ keystrokeActionSelector: keyActionSel
+ "Set the keystroke action selector as specified"
+
+ keystrokeActionSelector := keyActionSel!
Item was added:
+ ----- Method: PluggableListMorph>>keystrokePreviewSelector (in category 'selection') -----
+ keystrokePreviewSelector
+ ^ keystrokePreviewSelector!
Item was added:
+ ----- Method: PluggableListMorph>>keystrokePreviewSelector: (in category 'selection') -----
+ keystrokePreviewSelector: sel
+ "The method on the model that will be given first view of any keystroke events. For access via scripting"
+
+ keystrokePreviewSelector := sel!
Item was added:
+ ----- Method: PluggableListMorph>>list: (in category 'initialization') -----
+ list: listOfStrings
+ "lex doesn't think this is used any longer, but is not yet brave enough to remove it. It should be removed eventually"
+
+
+ "Set the receiver's list as specified"
+
+ | morphList h index converter aSelector textColor font loc |
+ self isThisEverCalled.
+ scroller removeAllMorphs.
+ list := listOfStrings ifNil: [Array new].
+ list isEmpty ifTrue: [self setScrollDeltas. ^ self selectedMorph: nil].
+ "NOTE: we will want a quick StringMorph init message, possibly even
+ combined with event install and positioning"
+ font ifNil: [font := Preferences standardListFont].
+ converter := self valueOfProperty: #itemConversionMethod.
+ converter ifNil: [converter := #asStringOrText].
+ textColor := self valueOfProperty: #textColor.
+ morphList := list collect: [:each | | stringMorph item |
+ item := each.
+ item := item perform: converter.
+ stringMorph := item isText
+ ifTrue: [StringMorph contents: item font: font emphasis: (item emphasisAt: 1)]
+ ifFalse: [StringMorph contents: item font: font].
+ textColor ifNotNil: [ stringMorph color: textColor ].
+ stringMorph
+ ].
+
+ (aSelector := self valueOfProperty: #balloonTextSelectorForSubMorphs)
+ ifNotNil:
+ [morphList do: [:m | m balloonTextSelector: aSelector]].
+
+ self highlightSelector ifNotNil:
+ [model perform: self highlightSelector with: list with: morphList].
+
+ "Lay items out vertically and install them in the scroller"
+ h := morphList first height "self listItemHeight".
+ loc := 0 at 0.
+ morphList do: [:m | m bounds: (loc extent: 9999 at h). loc := loc + (0 at h)].
+ scroller addAllMorphs: morphList.
+
+ index := self getCurrentSelectionIndex.
+ self selectedMorph: ((index = 0 or: [index > morphList size]) ifTrue: [nil] ifFalse: [morphList at: index]).
+ self setScrollDeltas.
+ scrollBar setValue: 0.0!
Item was added:
+ ----- Method: PluggableListMorph>>listItemHeight (in category 'initialization') -----
+ listItemHeight
+ "This should be cleaned up. The list should get spaced by this parameter."
+ ^ 12!
Item was added:
+ ----- Method: PluggableListMorph>>listMorph (in category 'as yet unclassified') -----
+ listMorph
+ listMorph ifNil: [
+ "crate this lazily, in case the morph is legacy"
+ listMorph := self listMorphClass new.
+ listMorph listSource: self.
+ listMorph width: self scroller width.
+ listMorph color: self textColor ].
+
+ listMorph owner ~~ self scroller ifTrue: [
+ "list morph needs to be installed. Again, it's done this way to accomodate legacy PluggableListMorphs"
+ self scroller removeAllMorphs.
+ self scroller addMorph: listMorph ].
+
+ ^listMorph!
Item was added:
+ ----- Method: PluggableListMorph>>listMorphClass (in category 'as yet unclassified') -----
+ listMorphClass
+ ^LazyListMorph!
Item was added:
+ ----- Method: PluggableListMorph>>maximumSelection (in category 'selection') -----
+ maximumSelection
+ ^ self getListSize!
Item was added:
+ ----- Method: PluggableListMorph>>minimumSelection (in category 'selection') -----
+ minimumSelection
+ ^ 1!
Item was added:
+ ----- Method: PluggableListMorph>>modelIndexFor: (in category 'selection') -----
+ modelIndexFor: selectionIndex
+ "The model does not know anything about the receiver's filtering, so if I am filtered, we must determine the correct index by scanning the full list in the model."
+ ^ (selectionIndex > 0 and: [ self hasFilter ])
+ ifTrue:
+ [ list
+ ifEmpty: [ 0 ]
+ ifNotEmpty: [ self getFullList indexOf: (self getListItem: selectionIndex) ] ]
+ ifFalse: [ selectionIndex ]!
Item was added:
+ ----- Method: PluggableListMorph>>modifierKeyPressed: (in category 'model access') -----
+ modifierKeyPressed: aChar
+ | args |
+ keystrokeActionSelector isNil ifTrue: [^nil].
+ args := keystrokeActionSelector numArgs.
+ args = 1 ifTrue: [^model perform: keystrokeActionSelector with: aChar].
+ args = 2
+ ifTrue:
+ [^model
+ perform: keystrokeActionSelector
+ with: aChar
+ with: self].
+ ^self error: 'keystrokeActionSelector must be a 1- or 2-keyword symbol'!
Item was added:
+ ----- Method: PluggableListMorph>>mouseDown: (in category 'events') -----
+ mouseDown: evt
+ | selectors row |
+ row := self rowAtLocation: evt position.
+
+ evt yellowButtonPressed "First check for option (menu) click"
+ ifTrue: [
+ (self class menuRequestUpdatesSelection and: [model okToChange]) ifTrue: [
+ "Models depend on the correct selection:"
+ self selectionIndex = (self modelIndexFor: row)
+ ifFalse: [self changeModelSelection: (self modelIndexFor: row)]].
+
+ ^ self yellowButtonActivity: evt shiftPressed].
+ row = 0 ifTrue: [^super mouseDown: evt].
+ "self dragEnabled ifTrue: [aMorph highlightForMouseDown]."
+ selectors := Array
+ with: #click:
+ with: (doubleClickSelector ifNotNil:[#doubleClick:])
+ with: nil
+ with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]).
+ evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: HandMorph dragThreshold "pixels".!
Item was added:
+ ----- Method: PluggableListMorph>>mouseDown:onItem: (in category 'obsolete') -----
+ mouseDown: event onItem: aMorph
+ self removeObsoleteEventHandlers.!
Item was added:
+ ----- Method: PluggableListMorph>>mouseEnter: (in category 'events') -----
+ mouseEnter: event
+ super mouseEnter: event.
+ self flag: #arNote. "remove this - keyboard input automatically goes right"
+ Preferences mouseOverForKeyboardFocus ifTrue:[
+ event hand newKeyboardFocus: self. ]!
Item was added:
+ ----- Method: PluggableListMorph>>mouseEnterDragging: (in category 'events') -----
+ mouseEnterDragging: evt
+
+ (evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d"
+ ^super mouseEnterDragging: evt].
+
+ (self wantsDroppedMorph: evt hand firstSubmorph event: evt )
+ ifTrue:[
+ potentialDropRow := self rowAtLocation: evt position.
+ evt hand newMouseFocus: self.
+ self changed.
+ "above is ugly but necessary for now"
+ ].
+ !
Item was added:
+ ----- Method: PluggableListMorph>>mouseEnterDragging:onItem: (in category 'obsolete') -----
+ mouseEnterDragging: anEvent onItem: aMorph
+ self removeObsoleteEventHandlers.!
Item was added:
+ ----- Method: PluggableListMorph>>mouseLeave: (in category 'events') -----
+ mouseLeave: event
+ "The mouse has left the area of the receiver"
+
+ super mouseLeave: event.
+
+ self hoverRow: nil.
+
+ Preferences mouseOverForKeyboardFocus ifTrue:[
+ event hand releaseKeyboardFocus: self].!
Item was added:
+ ----- Method: PluggableListMorph>>mouseLeaveDragging: (in category 'events') -----
+ mouseLeaveDragging: anEvent
+
+ self hoverRow: nil.
+ (self dropEnabled and:[anEvent hand hasSubmorphs]) ifFalse: ["no d&d"
+ ^ super mouseLeaveDragging: anEvent].
+ self resetPotentialDropRow.
+ anEvent hand releaseMouseFocus: self.
+ "above is ugly but necessary for now"
+ !
Item was added:
+ ----- Method: PluggableListMorph>>mouseLeaveDragging:onItem: (in category 'obsolete') -----
+ mouseLeaveDragging: anEvent onItem: aMorph
+ self removeObsoleteEventHandlers.!
Item was added:
+ ----- Method: PluggableListMorph>>mouseMove: (in category 'events') -----
+ mouseMove: evt
+
+ (self dropEnabled and:[evt hand hasSubmorphs])
+ ifFalse:[^super mouseMove: evt].
+ potentialDropRow ifNotNil:[
+ potentialDropRow = (self rowAtLocation: evt position)
+ ifTrue:[^self].
+ ].
+ self mouseLeaveDragging: evt.
+ (self containsPoint: evt position)
+ ifTrue:[self mouseEnterDragging: evt].!
Item was added:
+ ----- Method: PluggableListMorph>>mouseUp: (in category 'events') -----
+ mouseUp: event
+ "The mouse came up within the list; take appropriate action"
+ | row |
+ row := self rowAtLocation: event position.
+ "aMorph ifNotNil: [aMorph highlightForMouseDown: false]."
+ model okToChange
+ ifFalse: [^ self].
+ "No change if model is locked"
+ row = self selectionIndex
+ ifTrue: [(autoDeselect ifNil: [true]) ifTrue:[row = 0 ifFalse: [self changeModelSelection: 0] ]]
+ ifFalse: [self changeModelSelection: (self modelIndexFor: row)].
+ event hand newKeyboardFocus: self.
+ hasFocus := true.
+ Cursor normal show!
Item was added:
+ ----- Method: PluggableListMorph>>mouseUp:onItem: (in category 'obsolete') -----
+ mouseUp: event onItem: aMorph
+ self removeObsoleteEventHandlers.!
Item was added:
+ ----- Method: PluggableListMorph>>numSelectionsInView (in category 'scrolling') -----
+ numSelectionsInView
+ "Answer the scroller's height based on the average number of submorphs."
+
+ (scroller submorphCount > 0) ifFalse:[ ^0 ].
+
+ "ugly hack, due to code smell.
+ PluggableListMorph added another level of indirection,
+ There is always only one submorph - a LazyListMorph which holds the actual list,
+ but TransformMorph doesn't know that and we are left with a breach of interface.
+
+ see vUnadjustedScrollRange for another bad example."
+
+ ^scroller numberOfItemsPotentiallyInViewWith: (scroller
+ submorphs last getListSize).!
Item was added:
+ ----- Method: PluggableListMorph>>on:list:selected:changeSelected:menu:keystroke: (in category 'initialization') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
+ self model: anObject.
+ getListSelector := getListSel.
+ getIndexSelector := getSelectionSel.
+ setIndexSelector := setSelectionSel.
+ getMenuSelector := getMenuSel.
+ keystrokeActionSelector := keyActionSel.
+ autoDeselect := true.
+ self borderWidth: 1.
+ self updateList.
+ self selectionIndex: self getCurrentSelectionIndex.
+ self initForKeystrokes!
Item was added:
+ ----- Method: PluggableListMorph>>potentialDropItem (in category 'drag and drop') -----
+ potentialDropItem
+ "return the item that the most recent drop hovered over, or nil if there is no potential drop target"
+ self potentialDropRow = 0 ifTrue: [ ^self ].
+ ^self getListItem: self potentialDropRow!
Item was added:
+ ----- Method: PluggableListMorph>>potentialDropRow (in category 'drag and drop') -----
+ potentialDropRow
+ "return the row of the item that the most recent drop hovered over, or 0 if there is no potential drop target"
+ ^potentialDropRow ifNil: [ 0 ].
+ !
Item was added:
+ ----- Method: PluggableListMorph>>previewKeystroke: (in category 'model access') -----
+ previewKeystroke: event
+ "Let the model decide if it's going to handle the event for us"
+
+ ^ keystrokePreviewSelector
+ ifNil: [ false ]
+ ifNotNil: [ model perform: keystrokePreviewSelector with: event ]!
Item was added:
+ ----- Method: PluggableListMorph>>removeFilter (in category 'model access') -----
+ removeFilter
+ lastKeystrokes := String empty.
+ list := nil!
Item was added:
+ ----- Method: PluggableListMorph>>removeObsoleteEventHandlers (in category 'obsolete') -----
+ removeObsoleteEventHandlers
+ scroller submorphs do:[:m|
+ m eventHandler: nil; highlightForMouseDown: false; resetExtension].!
Item was added:
+ ----- Method: PluggableListMorph>>resetHScrollRange (in category 'scroll cache') -----
+ resetHScrollRange
+
+ hScrollRangeCache := nil.
+ self deriveHScrollRange.
+ !
Item was added:
+ ----- Method: PluggableListMorph>>resetHScrollRangeIfNecessary (in category 'scroll cache') -----
+ resetHScrollRangeIfNecessary
+
+ hScrollRangeCache ifNil: [ ^self deriveHScrollRange ].
+
+ (list isNil or: [list isEmpty])
+ ifTrue:[^hScrollRangeCache := Array with: 0 with: 0 with: 0 with: 0 with: 0].
+
+ "Make a guess as to whether the scroll ranges need updating based on whether the size, first item, or last item of the list has changed"
+ (
+ (hScrollRangeCache third == list size) and: [
+ (hScrollRangeCache fourth == list first) and: [
+ (hScrollRangeCache fifth == list last)
+ ]])
+ ifFalse:[self deriveHScrollRange].
+
+ !
Item was added:
+ ----- Method: PluggableListMorph>>resetPotentialDropRow (in category 'drag and drop') -----
+ resetPotentialDropRow
+ potentialDropRow ifNotNil: [
+ potentialDropRow ~= 0 ifTrue: [
+ potentialDropRow := 0.
+ self changed. ] ]!
Item was added:
+ ----- Method: PluggableListMorph>>resizeScrollBars (in category 'scroll cache') -----
+ resizeScrollBars
+
+
+ (self extent = self defaultExtent)
+ ifTrue:[
+ WorldState addDeferredUIMessage:
+ [ self vResizeScrollBar; resizeScroller; hResizeScrollBar]
+ ]
+ ifFalse:[self vResizeScrollBar; hResizeScrollBar].
+
+
+ !
Item was added:
+ ----- Method: PluggableListMorph>>rowAboutToBecomeSelected: (in category 'selection') -----
+ rowAboutToBecomeSelected: anInteger
+
+ self listMorph preSelectedRow: anInteger!
Item was added:
+ ----- Method: PluggableListMorph>>rowAtLocation: (in category 'accessing') -----
+ rowAtLocation: aPoint
+ "Return the row at the given point or 0 if outside"
+ | pointInListMorphCoords |
+ pointInListMorphCoords := (self scroller transformFrom: self) transform: aPoint.
+ ^self listMorph rowAtLocation: pointInListMorphCoords.!
Item was added:
+ ----- Method: PluggableListMorph>>scrollDeltaHeight (in category 'geometry') -----
+ scrollDeltaHeight
+ "Return the increment in pixels which this pane should be scrolled."
+ ^ self font height!
Item was added:
+ ----- Method: PluggableListMorph>>scrollDeltaWidth (in category 'geometry') -----
+ scrollDeltaWidth
+ "A guess -- assume that the width of a char is approx 1/2 the height of the font"
+ ^ self scrollDeltaHeight // 2
+
+ !
Item was added:
+ ----- Method: PluggableListMorph>>scrollSelectionIntoView (in category 'selection') -----
+ scrollSelectionIntoView
+ "make sure that the current selection is visible"
+ | row |
+ row := self uiIndexFor: self getCurrentSelectionIndex.
+ row = 0 ifTrue: [ ^ self ].
+ self scrollToShow: (self listMorph drawBoundsForRow: row)!
Item was added:
+ ----- Method: PluggableListMorph>>selectedMorph (in category 'selection') -----
+ selectedMorph
+ "this doesn't work with the LargeLists patch!! Use #selectionIndex and #selection instead."
+ ^self scroller submorphs at: self selectionIndex!
Item was added:
+ ----- Method: PluggableListMorph>>selectedMorph: (in category 'selection') -----
+ selectedMorph: aMorph
+ "this shouldn't be used any longer. Only sent by implemetations of #list: such as PluggableListMorph, SimpleHierarchicalListMorph etc"
+
+ self isThisEverCalled .
+ true ifTrue: [^self]!
Item was added:
+ ----- Method: PluggableListMorph>>selection (in category 'selection') -----
+ selection
+ self selectionIndex = 0 ifTrue: [ ^nil ].
+ list ifNotNil: [ ^list at: self selectionIndex ].
+ ^ self getListItem: self selectionIndex!
Item was added:
+ ----- Method: PluggableListMorph>>selection: (in category 'selection') -----
+ selection: item
+ "Called from outside to request setting a new selection."
+
+ self selectionIndex: (self getList indexOf: item)!
Item was added:
+ ----- Method: PluggableListMorph>>selectionIndex (in category 'selection') -----
+ selectionIndex
+ "return the index we have currently selected, or 0 if none"
+ ^self listMorph selectedRow ifNil: [ 0 ]!
Item was added:
+ ----- Method: PluggableListMorph>>selectionIndex: (in category 'selection') -----
+ selectionIndex: index
+ "Called internally to select the index-th item."
+ | row |
+ self unhighlightSelection.
+ row := index ifNil: [ 0 ].
+ row := row min: self getListSize. "make sure we don't select past the end"
+ self listMorph selectedRow: row.
+ self highlightSelection.
+ self scrollSelectionIntoView.!
Item was added:
+ ----- Method: PluggableListMorph>>setGetListSelector: (in category 'selection') -----
+ setGetListSelector: sel
+ "Set the the receiver's getListSelector as indicated. For access via scripting"
+
+ getListSelector := sel!
Item was added:
+ ----- Method: PluggableListMorph>>setListFont (in category 'menus') -----
+ setListFont
+ "set the font for the list"
+
+ Preferences
+ chooseFontWithPrompt: 'Choose the font for this list' translated
+ andSendTo: self
+ withSelector: #font:
+ highlightSelector: #font!
Item was added:
+ ----- Method: PluggableListMorph>>setSelectedMorph: (in category 'selection') -----
+ setSelectedMorph: aMorph
+ self changeModelSelection: (self modelIndexFor: (scroller submorphs indexOf: aMorph))!
Item was added:
+ ----- Method: PluggableListMorph>>specialKeyPressed: (in category 'model access') -----
+ specialKeyPressed: asciiValue
+ "A special key with the given ascii-value was pressed; dispatch it"
+ | oldSelection nextSelection max howManyItemsShowing |
+ (#(8 13) includes: asciiValue) ifTrue:
+ [ "backspace key - clear the filter, restore the list with the selection"
+ self removeFilter.
+ priorSelection ifNotNil:
+ [ | prior |
+ prior := priorSelection.
+ priorSelection := self getCurrentSelectionIndex.
+ asciiValue = 8 ifTrue: [ self changeModelSelection: prior ] ].
+ ^ self updateList ].
+ asciiValue = 27 ifTrue:
+ [" escape key"
+ ^ ActiveEvent shiftPressed
+ ifTrue:
+ [ActiveWorld putUpWorldMenuFromEscapeKey]
+ ifFalse:
+ [self yellowButtonActivity: false]].
+
+ max := self maximumSelection.
+ max > 0 ifFalse: [^ self].
+ nextSelection := oldSelection := self selectionIndex.
+ asciiValue = 31 ifTrue:
+ [" down arrow"
+ nextSelection := oldSelection + 1.
+ nextSelection > max ifTrue: [nextSelection := 1]].
+ asciiValue = 30 ifTrue:
+ [" up arrow"
+ nextSelection := oldSelection - 1.
+ nextSelection < 1 ifTrue: [nextSelection := max]].
+ asciiValue = 1 ifTrue:
+ [" home"
+ nextSelection := 1].
+ asciiValue = 4 ifTrue:
+ [" end"
+ nextSelection := max].
+ howManyItemsShowing := self numSelectionsInView.
+ asciiValue = 11 ifTrue:
+ [" page up"
+ nextSelection := 1 max: oldSelection - howManyItemsShowing].
+ asciiValue = 12 ifTrue:
+ [" page down"
+ nextSelection := oldSelection + howManyItemsShowing min: max].
+ model okToChange ifFalse: [^ self].
+ "No change if model is locked"
+ oldSelection = nextSelection ifTrue: [^ self flash].
+ ^ self changeModelSelection: (self modelIndexFor: nextSelection)!
Item was added:
+ ----- Method: PluggableListMorph>>startDrag: (in category 'drag and drop') -----
+ startDrag: evt
+
+ evt hand hasSubmorphs
+ ifTrue: [^ self].
+ [ | draggedItem draggedItemMorph passenger ddm |
+ (self dragEnabled and: [model okToChange])
+ ifFalse: [^ self].
+ (draggedItem := self selection)
+ ifNil: [^ self].
+ draggedItemMorph := StringMorph contents: draggedItem asStringOrText.
+ passenger := self model dragPassengerFor: draggedItemMorph inMorph: self.
+ passenger
+ ifNil: [^ self].
+ ddm := TransferMorph withPassenger: passenger from: self.
+ ddm
+ dragTransferType: (self model dragTransferTypeForMorph: self).
+ Preferences dragNDropWithAnimation
+ ifTrue: [self model dragAnimationFor: draggedItemMorph transferMorph: ddm].
+ evt hand grabMorph: ddm]
+ ensure: [Cursor normal show.
+ evt hand releaseMouseFocus: self]!
Item was added:
+ ----- Method: PluggableListMorph>>startDrag:onItem: (in category 'obsolete') -----
+ startDrag: evt onItem: itemMorph
+ self removeObsoleteEventHandlers.!
Item was added:
+ ----- Method: PluggableListMorph>>textColor (in category 'initialization') -----
+ textColor
+ "Answer my default text color."
+ ^self valueOfProperty: #textColor ifAbsent: [ Color black ]
+ !
Item was added:
+ ----- Method: PluggableListMorph>>textColor: (in category 'initialization') -----
+ textColor: aColor
+ "Set my default text color."
+ self setProperty: #textColor toValue: aColor.
+ self listMorph color: aColor.!
Item was added:
+ ----- Method: PluggableListMorph>>textHighlightColor (in category 'initialization') -----
+ textHighlightColor
+ "Answer my default text highlight color."
+ ^self valueOfProperty: #textHighlightColor ifAbsent: [ self textColor negated ].
+ !
Item was added:
+ ----- Method: PluggableListMorph>>textHighlightColor: (in category 'initialization') -----
+ textHighlightColor: aColor
+ "Set my default text highlight color."
+ self setProperty: #textHighlightColor toValue: aColor.
+ !
Item was added:
+ ----- Method: PluggableListMorph>>topVisibleRowIndex (in category 'accessing') -----
+ topVisibleRowIndex
+ ^ self rowAtLocation: self topLeft+(3 at 3)!
Item was added:
+ ----- Method: PluggableListMorph>>uiIndexFor: (in category 'selection') -----
+ uiIndexFor: modelIndex
+ "The model does not know anything about the receiver's filtering. Answer the index in my (possibly filtered) list for modelIndex."
+ (modelIndex > 0 and: [ self hasFilter ])
+ ifTrue:
+ [ | selectedItem |
+ selectedItem := self getFullList at: modelIndex.
+ (list ifNil: [ self getList ]) withIndexDo:
+ [ : eachMatchingItem : n | eachMatchingItem = selectedItem ifTrue: [ ^ n ] ].
+ ^ 0 ]
+ ifFalse: [ ^ modelIndex ]!
Item was added:
+ ----- Method: PluggableListMorph>>unhighlightSelection (in category 'drawing') -----
+ unhighlightSelection
+ !
Item was added:
+ ----- Method: PluggableListMorph>>update: (in category 'updating') -----
+ update: aSymbol
+ "Refer to the comment in View|update:."
+ aSymbol == getListSelector ifTrue:
+ [ self updateList.
+ ^ self ].
+ aSymbol == getIndexSelector ifTrue:
+ [ | uiIndex modelIndex |
+ uiIndex := self uiIndexFor: (modelIndex := self getCurrentSelectionIndex).
+ self selectionIndex:
+ (uiIndex = 0
+ ifTrue:
+ [ "The filter is preventing us from selecting the item we want - remove it."
+ (modelIndex > 0 and: [list notNil and: [list size > 0]]) ifTrue: [ self removeFilter ].
+ modelIndex ]
+ ifFalse: [ uiIndex ]).
+ ^ self ]!
Item was added:
+ ----- Method: PluggableListMorph>>updateList (in category 'updating') -----
+ updateList
+ | index |
+ "the list has changed -- update from the model"
+ self listMorph listChanged.
+ self setScrollDeltas.
+ index := self getCurrentSelectionIndex.
+ self resetPotentialDropRow.
+ self selectionIndex: (self uiIndexFor: index).
+ !
Item was added:
+ ----- Method: PluggableListMorph>>userString (in category 'debug and other') -----
+ userString
+ "Do I have a text string to be searched on?"
+
+ ^ String streamContents: [:strm |
+ 1 to: self getListSize do: [:i |
+ "must use asStringOrText because that's what the drawing uses, too"
+ strm nextPutAll: (self getListItem: i) asStringOrText; cr]]!
Item was added:
+ ----- Method: PluggableListMorph>>vUnadjustedScrollRange (in category 'scrolling') -----
+ vUnadjustedScrollRange
+ "Return the height extent of the receiver's submorphs."
+ (scroller submorphs size > 0) ifFalse:[ ^0 ].
+ ^(scroller submorphs last fullBounds bottom)
+ !
Item was added:
+ ----- Method: PluggableListMorph>>verifyContents (in category 'updating') -----
+ verifyContents
+ "Verify the contents of the receiver, reconstituting if necessary. Called whenever window is reactivated, to react to possible structural changes. Also called periodically in morphic if the smartUpdating preference is true"
+ | newList existingSelection anIndex oldList |
+ oldList := list ifNil: [ #() ].
+ newList := self getList.
+ oldList = newList ifTrue: [ ^ self ].
+ existingSelection := oldList at: self selectionIndex ifAbsent: [ nil ].
+ self updateList.
+ (existingSelection notNil and: [(anIndex := self getFullList indexOf: existingSelection asStringOrText ifAbsent: [nil]) notNil])
+ ifTrue:
+ [model noteSelectionIndex: anIndex for: getListSelector.
+ self selectionIndex: anIndex]
+ ifFalse:
+ [self changeModelSelection: 0]!
Item was added:
+ ----- Method: PluggableListMorph>>visibleList (in category 'accessing') -----
+ visibleList
+ ^ list isEmptyOrNil
+ ifTrue: [ Array empty ]
+ ifFalse:
+ [ list
+ copyFrom: self topVisibleRowIndex
+ to: (self bottomVisibleRowIndex min: list size) ]!
Item was added:
+ ----- Method: PluggableListMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
+ wantsDroppedMorph: aMorph event: anEvent
+ ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self!
Item was added:
+ PluggableListMorph subclass: #PluggableListMorphByItem
+ instanceVariableNames: 'itemList'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
Item was added:
+ ----- Method: PluggableListMorphByItem>>changeModelSelection: (in category 'model access') -----
+ changeModelSelection: anInteger
+ "Change the model's selected item to be the one at the given index."
+
+ | item |
+ setIndexSelector ifNotNil: [
+ item := (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]).
+ model perform: setIndexSelector with: item].
+ self update: getIndexSelector.
+ !
Item was added:
+ ----- Method: PluggableListMorphByItem>>getCurrentSelectionIndex (in category 'model access') -----
+ getCurrentSelectionIndex
+ "Answer the index of the current selection."
+ | item |
+ getIndexSelector == nil ifTrue: [^ 0].
+ item := model perform: getIndexSelector.
+ ^ list findFirst: [ :x | x = item]
+ !
Item was added:
+ ----- Method: PluggableListMorphByItem>>getList (in category 'as yet unclassified') -----
+ getList
+ "cache the raw items in itemList"
+ itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ].
+ ^super getList!
Item was added:
+ ----- Method: PluggableListMorphByItem>>list: (in category 'initialization') -----
+ list: arrayOfStrings
+ "Set the receivers items to be the given list of strings."
+ "Note: the instance variable 'items' holds the original list.
+ The instance variable 'list' is a paragraph constructed from
+ this list."
+ "NOTE: this is no longer true; list is a real list, and itemList is no longer used. And this method shouldn't be called, incidentally."
+ self isThisEverCalled .
+ itemList := arrayOfStrings.
+ ^ super list: arrayOfStrings!
Item was added:
+ PluggableListMorph subclass: #PluggableListMorphOfMany
+ instanceVariableNames: 'dragOnOrOff getSelectionListSelector setSelectionListSelector'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
+
+ !PluggableListMorphOfMany commentStamp: 'hpt 4/5/2004 11:21' prior: 0!
+ A variant of its superclass that allows multiple items to be selected simultaneously. There is still a distinguished element which is selected, but each other element in the list may be flagged on or off.
+ !
Item was added:
+ ----- Method: PluggableListMorphOfMany class>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:menu: (in category 'instance creation') -----
+ on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel
+ ^ self new
+ on: anObject
+ list: listSel
+ primarySelection: getSelectionSel
+ changePrimarySelection: setSelectionSel
+ listSelection: getListSel
+ changeListSelection: setListSel
+ menu: getMenuSel
+ keystroke: #arrowKey:from: "default"!
Item was added:
+ ----- Method: PluggableListMorphOfMany class>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:menu:keystroke: (in category 'instance creation') -----
+ on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel
+ ^ self new
+ on: anObject
+ list: listSel
+ primarySelection: getSelectionSel
+ changePrimarySelection: setSelectionSel
+ listSelection: getListSel
+ changeListSelection: setListSel
+ menu: getMenuSel
+ keystroke: keyActionSel!
Item was added:
+ ----- Method: PluggableListMorphOfMany>>itemSelectedAmongMultiple: (in category 'model access') -----
+ itemSelectedAmongMultiple: index
+ ^self listSelectionAt: (self modelIndexFor: index)!
Item was added:
+ ----- Method: PluggableListMorphOfMany>>list: (in category 'initialization') -----
+ list: listOfStrings
+ scroller removeAllMorphs.
+ list := listOfStrings ifNil: [Array new].
+ list isEmpty ifTrue: [^ self selectedMorph: nil].
+ super list: listOfStrings.
+
+ "At this point first morph is sensitized, and all morphs share same handler."
+ scroller firstSubmorph on: #mouseEnterDragging
+ send: #mouseEnterDragging:onItem:
+ to: self.
+ scroller firstSubmorph on: #mouseUp
+ send: #mouseUp:onItem:
+ to: self.
+ "This should add this behavior to the shared event handler thus affecting all items"!
Item was added:
+ ----- Method: PluggableListMorphOfMany>>listSelectionAt: (in category 'drawing') -----
+ listSelectionAt: index
+ getSelectionListSelector ifNil:[^false].
+ ^model perform: getSelectionListSelector with: index!
Item was added:
+ ----- Method: PluggableListMorphOfMany>>listSelectionAt:put: (in category 'drawing') -----
+ listSelectionAt: index put: value
+ setSelectionListSelector ifNil:[^false].
+ ^model perform: setSelectionListSelector with: index with: value!
Item was added:
+ ----- Method: PluggableListMorphOfMany>>mouseDown: (in category 'event handling') -----
+ mouseDown: event
+ | oldIndex oldVal row index |
+ event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed].
+ row := self rowAtLocation: event position.
+
+ row = 0 ifTrue: [^super mouseDown: event].
+ index := self modelIndexFor: row.
+
+ model okToChange ifFalse: [^ self]. "No change if model is locked"
+
+ "Set meaning for subsequent dragging of selection"
+ dragOnOrOff := (self listSelectionAt: index) not.
+ oldIndex := self getCurrentSelectionIndex.
+ oldIndex ~= 0 ifTrue: [oldVal := self listSelectionAt: oldIndex].
+
+ "Set or clear new primary selection (listIndex)"
+ dragOnOrOff
+ ifTrue: [self changeModelSelection: index]
+ ifFalse: [self changeModelSelection: 0].
+
+ "Need to restore the old one, due to how model works, and set new one."
+ oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal].
+ self listSelectionAt: index put: dragOnOrOff.
+ "event hand releaseMouseFocus: aMorph."
+ !
Item was added:
+ ----- Method: PluggableListMorphOfMany>>mouseMove: (in category 'event handling') -----
+ mouseMove: event
+ "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate"
+
+ | oldIndex oldVal row index |
+ event position y < self top
+ ifTrue:
+ [scrollBar scrollUp: 1.
+ row := self rowAtLocation: scroller topLeft + (1 @ 1)]
+ ifFalse:
+ [row := event position y > self bottom
+ ifTrue:
+ [scrollBar scrollDown: 1.
+ self rowAtLocation: scroller bottomLeft + (1 @ -1)]
+ ifFalse: [ self rowAtLocation: event position]].
+ row = 0 ifTrue: [^super mouseDown: event].
+ index := self modelIndexFor: row.
+
+ model okToChange ifFalse: [^self]. "No change if model is locked"
+
+ dragOnOrOff ifNil:
+ ["Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item"
+ dragOnOrOff := (self listSelectionAt: index) not].
+
+ "Set meaning for subsequent dragging of selection"
+ oldIndex := self getCurrentSelectionIndex.
+ oldIndex ~= 0 ifTrue: [oldVal := self listSelectionAt: oldIndex].
+
+ "Set or clear new primary selection (listIndex)"
+ dragOnOrOff
+ ifTrue: [self changeModelSelection: index]
+ ifFalse: [self changeModelSelection: 0].
+
+ "Need to restore the old one, due to how model works, and set new one."
+ oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal].
+ self listSelectionAt: index put: dragOnOrOff.
+ !
Item was added:
+ ----- Method: PluggableListMorphOfMany>>mouseUp: (in category 'event handling') -----
+ mouseUp: event
+
+ dragOnOrOff := nil. "So improperly started drags will have not effect"
+ event hand newKeyboardFocus: self.
+ hasFocus := true.!
Item was added:
+ ----- Method: PluggableListMorphOfMany>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:menu:keystroke: (in category 'initialization') -----
+ on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel
+ "setup a whole load of pluggability options"
+ getSelectionListSelector := getListSel.
+ setSelectionListSelector := setListSel.
+ super on: anObject list: listSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
+ !
Item was added:
+ ----- Method: PluggableListMorphOfMany>>update: (in category 'updating') -----
+ update: aSymbol
+ aSymbol == #allSelections ifTrue:
+ [self selectionIndex: self getCurrentSelectionIndex.
+ ^ self changed].
+ ^ super update: aSymbol!
Item was added:
+ PluggableListMorph subclass: #PluggableMessageCategoryListMorph
+ instanceVariableNames: 'getRawListSelector priorRawList'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
+
+ !PluggableMessageCategoryListMorph commentStamp: '<historical>' prior: 0!
+ A variant of PluggableListMorph designed specially for efficient handling of the --all-- feature in message-list panes. In order to be able *quickly* to check whether there has been an external change to the list, we cache the raw list for identity comparison (the actual list is a combination of the --all-- element and the the actual list).!
Item was added:
+ ----- Method: PluggableMessageCategoryListMorph class>>on:list:selected:changeSelected:menu:keystroke:getRawListSelector: (in category 'as yet unclassified') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel
+ ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel!
Item was added:
+ ----- Method: PluggableMessageCategoryListMorph>>getList (in category 'model access') -----
+ getList
+ "Differs from the generic in that here we obtain and cache the raw list, then cons it together with the special '-- all --' item to produce the list to be used in the browser. This special handling is done in order to avoid excessive and unnecessary reformulation of the list in the step method"
+
+ getRawListSelector == nil ifTrue: ["should not happen!!" priorRawList := nil. ^ #()].
+ model classListIndex = 0 ifTrue: [^ priorRawList := list := Array new].
+ priorRawList := model perform: getRawListSelector.
+ list := (Array with: ClassOrganizer allCategory), priorRawList.
+ ^list!
Item was added:
+ ----- Method: PluggableMessageCategoryListMorph>>on:list:selected:changeSelected:menu:keystroke:getRawListSelector: (in category 'as yet unclassified') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel
+ self model: anObject.
+ getListSelector := getListSel.
+ getIndexSelector := getSelectionSel.
+ setIndexSelector := setSelectionSel.
+ getMenuSelector := getMenuSel.
+ keystrokeActionSelector := keyActionSel.
+ autoDeselect := true.
+ self borderWidth: 1.
+ getRawListSelector := getRawSel.
+ self updateList.
+ self selectionIndex: self getCurrentSelectionIndex.
+ self initForKeystrokes!
Item was added:
+ ----- Method: PluggableMessageCategoryListMorph>>verifyContents (in category 'updating') -----
+ verifyContents
+ | newList existingSelection anIndex newRawList |
+ (model editSelection == #editComment) ifTrue: [^ self].
+ model classListIndex = 0 ifTrue: [^ self].
+ newRawList := model perform: getRawListSelector.
+ newRawList == priorRawList ifTrue: [^ self]. "The usual case; very fast"
+ priorRawList := newRawList.
+ newList := (Array with: ClassOrganizer allCategory), priorRawList.
+ list = newList ifTrue: [^ self].
+ existingSelection := self selection.
+ self updateList.
+ (anIndex := newList indexOf: existingSelection ifAbsent: [nil])
+ ifNotNil:
+ [model noteSelectionIndex: anIndex for: getListSelector.
+ self selectionIndex: anIndex]
+ ifNil:
+ [self changeModelSelection: 0]!
Item was added:
+ PluggableListMorph subclass: #PluggableMultiColumnListMorph
+ instanceVariableNames: 'lists'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
+
+ !PluggableMultiColumnListMorph commentStamp: '<historical>' prior: 0!
+ This morph can be used to show a list having multiple columns, The columns are self width sized to make the largest entry in each list fit. In some cases the pane may then be too narrow.
+
+ Use it like a regular PluggableListMorph except pass in an array of lists instead of a single list.
+
+ There are base assumptions made here that each list in the array of lists is the same size.
+
+ Also, the highlight color for the selection is easy to modify in the #highlightSelection method. I used blue
+ when testing just to see it work.!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>basicKeyPressed: (in category 'model access') -----
+ basicKeyPressed: aChar
+ "net supported for multi-column lists; which column should be used?!! The issue is that the base class implementation uses getList expecting a single collectino to come back instead of several of them"
+ ^self!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>calculateColumnOffsetsFrom: (in category 'initialization') -----
+ calculateColumnOffsetsFrom: maxWidths
+ | offsets previous current |
+ offsets := Array new: maxWidths size.
+ 1
+ to: offsets size
+ do: [:indx | offsets at: indx put: (maxWidths at: indx)
+ + 10].
+ 2
+ to: offsets size
+ do: [:indx |
+ previous := offsets at: indx - 1.
+ current := offsets at: indx.
+ current := previous + current.
+ offsets at: indx put: current].
+ ^offsets
+ !
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>calculateColumnWidthsFrom: (in category 'initialization') -----
+ calculateColumnWidthsFrom: arrayOfMorphs
+ | maxWidths |
+ maxWidths := Array new: arrayOfMorphs size - 1.
+ 1
+ to: maxWidths size
+ do: [:idx | maxWidths at: idx put: 0].
+ 1
+ to: maxWidths size
+ do: [:idx | (arrayOfMorphs at: idx)
+ do: [:mitem | mitem width
+ > (maxWidths at: idx)
+ ifTrue: [maxWidths at: idx put: mitem width]]].
+ ^maxWidths!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>createMorphicListsFrom: (in category 'initialization') -----
+ createMorphicListsFrom: arrayOfLists
+ | array |
+
+ array := Array new: arrayOfLists size.
+ 1 to: arrayOfLists size do: [:arrayIndex |
+ array at: arrayIndex put: (
+ (arrayOfLists at: arrayIndex) collect: [:item | item isText
+ ifTrue: [StringMorph
+ contents: item
+ font: self font
+ emphasis: (item emphasisAt: 1)]
+ ifFalse: [StringMorph contents: item font: self font]])
+ ].
+ ^array!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>getList (in category 'model access') -----
+ getList
+ "fetch and answer the lists to be displayed"
+ getListSelector == nil ifTrue: [^ #()].
+ list := model perform: getListSelector.
+ list == nil ifTrue: [^ #()].
+ list := list collect: [ :column | column collect: [ :item | item asStringOrText ] ].
+ ^ list!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>getListRow: (in category 'accessing') -----
+ getListRow: row
+ "return the strings that should appear in the requested row"
+ getListElementSelector ifNotNil: [ ^model perform: getListElementSelector with: row ].
+ ^self getList collect: [ :l | l at: row ]!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>getListSize (in category 'accessing') -----
+ getListSize
+ | l |
+ getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ].
+
+ l := self getList.
+ l isEmpty ifTrue: [ ^ 0 ].
+ ^l first size!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>highlightSelection (in category 'selection') -----
+ highlightSelection
+ ^self!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>itemFromPoint: (in category 'accessing') -----
+ itemFromPoint: aPoint
+ "Return the list element (morph) at the given point or nil if outside"
+ | ptY |
+ scroller hasSubmorphs ifFalse:[^nil].
+ (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil].
+ ptY := (scroller firstSubmorph point: aPoint from: self) y.
+ "note: following assumes that submorphs are vertical, non-overlapping, and ordered"
+ scroller firstSubmorph top > ptY ifTrue:[^nil].
+ scroller lastSubmorph bottom < ptY ifTrue:[^nil].
+ "now use binary search"
+ ^scroller submorphThat: [ :item | item top <= ptY and:[item bottom >= ptY] ] ifNone: [].
+ !
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>layoutMorphicLists: (in category 'initialization') -----
+ layoutMorphicLists: arrayOfMorphs
+ | maxWidths offsets locs h |
+ maxWidths := self calculateColumnWidthsFrom: arrayOfMorphs.
+ offsets := self calculateColumnOffsetsFrom: maxWidths.
+ locs := Array new: arrayOfMorphs size.
+ locs at: 1 put: 0 @ 0.
+ 2
+ to: locs size
+ do: [:indx | locs at: indx put: (offsets at: indx - 1)
+ @ 0].
+ h := arrayOfMorphs first first height.
+ 1
+ to: arrayOfMorphs size
+ do: [:indx | (arrayOfMorphs at: indx)
+ do: [:morphItem |
+ morphItem
+ bounds: ((locs at: indx)
+ extent: 9999 @ h).
+ locs at: indx put: (locs at: indx)
+ + (0 @ h)]]!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>list: (in category 'initialization') -----
+ list: arrayOfLists
+ | listOfStrings |
+ lists := arrayOfLists.
+ scroller removeAllMorphs.
+ listOfStrings := arrayOfLists == nil
+ ifTrue: [Array new]
+ ifFalse: [
+ arrayOfLists isEmpty ifFalse: [
+ arrayOfLists at: 1]].
+ list := listOfStrings
+ ifNil: [Array new].
+ self listMorph listChanged..
+
+ self setScrollDeltas.
+ scrollBar setValue: 0.0!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>listMorphClass (in category 'accessing') -----
+ listMorphClass
+ ^MulticolumnLazyListMorph!
Item was added:
+ ----- Method: PluggableMultiColumnListMorph>>unhighlightSelection (in category 'selection') -----
+ unhighlightSelection
+ ^self!
Item was added:
+ PluggableMultiColumnListMorph subclass: #PluggableMultiColumnListMorphByItem
+ instanceVariableNames: 'itemList'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
Item was added:
+ ----- Method: PluggableMultiColumnListMorphByItem>>changeModelSelection: (in category 'model access') -----
+ changeModelSelection: anInteger
+ "Change the model's selected item to be the one at the given index."
+ | item |
+ setIndexSelector
+ ifNotNil: [item := anInteger = 0
+ ifFalse: [list first at: anInteger].
+ model perform: setIndexSelector with: item].
+ self update: getIndexSelector!
Item was added:
+ ----- Method: PluggableMultiColumnListMorphByItem>>getCurrentSelectionIndex (in category 'model access') -----
+ getCurrentSelectionIndex
+ "Answer the index of the current selection."
+ | item |
+ getIndexSelector == nil
+ ifTrue: [^ 0].
+ item := model perform: getIndexSelector.
+
+ ^ list first
+ findFirst: [:x | x = item]!
Item was added:
+ ----- Method: PluggableMultiColumnListMorphByItem>>list: (in category 'initialization') -----
+ list: arrayOfStrings
+ "Set the receivers items to be the given list of strings."
+ "Note: the instance variable 'items' holds the original list.
+ The instance variable 'list' is a paragraph constructed from
+ this list."
+ "NO LONGER TRUE. list is a real list, and listItems is obsolete."
+ self isThisEverCalled .
+ itemList := arrayOfStrings first.
+ ^ super list: arrayOfStrings!
Item was added:
+ ScrollPane subclass: #PluggableScrollPane
+ instanceVariableNames: 'morph morphClass'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
Item was added:
+ ----- Method: PluggableScrollPane class>>on: (in category 'instance creation') -----
+ on: morph
+
+ ^ self new
+ morph: morph;
+ yourself!
Item was added:
+ ----- Method: PluggableScrollPane class>>onClass: (in category 'instance creation') -----
+ onClass: morphClass
+
+ ^ self new
+ morphClass: morphClass;
+ updateMorph;
+ yourself!
Item was added:
+ ----- Method: PluggableScrollPane>>morph (in category 'accessing') -----
+ morph
+
+ ^ morph ifNil: [
+ self morph: self morphClass new.
+ morph]!
Item was added:
+ ----- Method: PluggableScrollPane>>morph: (in category 'accessing') -----
+ morph: morphToScroll
+
+ morphToScroll topLeft: 0 at 0.
+ morph := morphToScroll.
+ morphClass := morphToScroll class.
+
+ self scroller
+ removeAllMorphs;
+ addMorph: morph.
+
+ self updateMorph.!
Item was added:
+ ----- Method: PluggableScrollPane>>morphClass (in category 'accessing') -----
+ morphClass
+
+ ^ morphClass ifNil: [Morph]!
Item was added:
+ ----- Method: PluggableScrollPane>>morphClass: (in category 'accessing') -----
+ morphClass: aMorphClass
+
+ morphClass := aMorphClass.!
Item was added:
+ ----- Method: PluggableScrollPane>>updateMorph (in category 'updating') -----
+ updateMorph
+
+ self morph fullBounds.
+ self setScrollDeltas.
+
+ scrollBar setValue: 0.0.
+ hScrollBar setValue: 0.0.!
Item was added:
+ PluggableSystemWindow subclass: #PluggableSystemWindowWithLabelButton
+ instanceVariableNames: 'labelButton'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !PluggableSystemWindowWithLabelButton commentStamp: 'eem 6/29/2010 19:02' prior: 0!
+ A PluggableSystemWindowWithLabelButton provides the pull-down menu of browser panes in the multi-pane browser.
+
+ Instance Variables
+ labelButton: <BrowserPaneButtonMorph>
+
+ labelButton
+ - the labelButton is a hack to hold onto the panes of a multi-paned browser so that an inst var doesn't have to be added to the Browser hierarchy.
+ !
Item was added:
+ ----- Method: PluggableSystemWindowWithLabelButton>>adjustExtraButton (in category 'resize/collapse') -----
+ adjustExtraButton
+ labelButton ifNil: [^self].
+ labelButton
+ position: self innerBounds topLeft + (20 @ -3);
+ extent: self innerBounds extent * (0.4 at 1)!
Item was added:
+ ----- Method: PluggableSystemWindowWithLabelButton>>extent: (in category 'geometry') -----
+ extent: newExtent
+ super extent: newExtent.
+ self adjustExtraButton!
Item was added:
+ ----- Method: PluggableSystemWindowWithLabelButton>>savedMultiWindowState: (in category 'accessing') -----
+ savedMultiWindowState: aSavedMultiWindowState
+ labelButton := MultiWindowLabelButtonMorph
+ on: aSavedMultiWindowState
+ getState: nil
+ action: #selectWindowsMenu.
+ labelButton
+ triggerOnMouseDown: true;
+ savedMultiWindowState: aSavedMultiWindowState.
+ labelButton
+ layoutFrame: (LayoutFrame "i.e. in the left 40% of the title bar"
+ fractions: (0 at 0 corner: 0.4 at 0)
+ offsets: (20@ -20 corner: 0 at 0));
+ hResizing: #spaceFill;
+ vResizing: #spaceFill.
+ self addMorphFront: labelButton.
+ self adjustExtraButton!
Item was added:
+ Morph subclass: #PluggableTabButtonMorph
+ instanceVariableNames: 'active model textSelector arcLengths subMorph'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
+
+ !PluggableTabButtonMorph commentStamp: 'KLC 9/17/2004 11:27' prior: 0!
+ This is a specialized pluggable button morph that is meant to represent a tab in a set of tabs arranged horizontally. Each tab will overlap slightly when drawn. All but one tab will be drawn in left to right order in the specified color, but lighter. The active tab will be drawn last in the full color and slightly taller to indicate that it is selected. Clicking the active tab has no effect but clicking any other tab will change the active tab to the clicked tab.
+
+ This morph does not itself accept any events. The parent tab set will grab the mouse clicks and handle notifying the appropriate tabs that they have been activated or deactivated.
+
+ There is a single selector which provides the text for the button label and affects the width of the tab. When the width changes the tab will inform its parent that it has changed and that the layout needs to be updated. The model for the text selector of course should be the client for the tab set.
+
+ The button label can be a String, Text, or Morph. Texts work better than plain Strings.!
Item was added:
+ ----- Method: PluggableTabButtonMorph class>>on:label: (in category 'instance creation') -----
+ on: anObject label: getTextSelector
+ | instance |
+ instance := super new.
+ instance model: anObject.
+ instance textSelector: getTextSelector.
+ ^ instance !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>active (in category 'access') -----
+ active
+ active ifNil: [ active := false ].
+ ^ active!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>active: (in category 'access') -----
+ active: aBoolean
+ active := aBoolean.
+ self changed.!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>arcLengths (in category 'private - access') -----
+ arcLengths
+ arcLengths ifNil: [ self calculateArcLengths ].
+ ^ arcLengths!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>arcLengths: (in category 'private - access') -----
+ arcLengths: anArrayOfIntegers
+ arcLengths := anArrayOfIntegers
+ !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>calculateArcLengths (in category 'precalculations') -----
+ calculateArcLengths
+ | array radius |
+ radius := self cornerRadius.
+ array := Array new: radius.
+
+ 1 to: radius do: [ :i | | x |
+ x := i - 0.5.
+ array at: i
+ put: (radius - ((2 * x * radius) - (x * x)) sqrt) asInteger].
+
+ self arcLengths: array!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>cornerRadius (in category 'private - access') -----
+ cornerRadius
+ ^ 5
+ !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ self drawTabOn: aCanvas.
+ self drawSubMorphOn: aCanvas!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>drawSubMorphOn: (in category 'drawing') -----
+ drawSubMorphOn: aCanvas
+ | morphBounds |
+ morphBounds := self bounds insetBy: (self cornerRadius + 3) @ (self topInactiveGap // 2 + 2).
+ morphBounds := morphBounds translateBy: 0@(self topInactiveGap // 2 + 1).
+ self active ifTrue: [
+ morphBounds := morphBounds translateBy: 0@((self topInactiveGap // 2 + 1) negated)].
+ self subMorph bounds height < (morphBounds height)
+ ifTrue: [
+ morphBounds := morphBounds
+ insetBy: 0@((morphBounds height - self subMorph bounds height) // 2)].
+ self subMorph bounds width < (morphBounds width)
+ ifTrue: [
+ morphBounds := morphBounds
+ insetBy: ((morphBounds width - self subMorph bounds width) // 2)@0].
+
+ self subMorph bounds: morphBounds.
+ aCanvas drawMorph: self subMorph!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>drawTabOn: (in category 'drawing') -----
+ drawTabOn: aCanvas
+ | top myColor cornerRadius myArcLengths myBounds |
+ cornerRadius := self cornerRadius.
+ myBounds := self bounds.
+ self active
+ ifTrue: [ top := myBounds top.
+ myColor := self color ]
+ ifFalse: [ top := myBounds top + self topInactiveGap.
+ myColor := self color whiter whiter ].
+ aCanvas fillRectangle:
+ ((myBounds left + cornerRadius)
+ @ (top + cornerRadius)
+ corner: (myBounds right - cornerRadius)
+ @ self bottom)
+ color: myColor.
+ aCanvas fillRectangle:
+ ((myBounds left + (cornerRadius * 2)) @ top
+ corner: (myBounds right - (cornerRadius * 2))
+ @ (top + cornerRadius))
+ color: myColor.
+ aCanvas fillOval:
+ ((myBounds left + self cornerRadius) @ top
+ corner: (myBounds left + (self cornerRadius * 3))
+ @ (top + (self cornerRadius * 2)))
+ color: myColor.
+ aCanvas fillOval:
+ ((myBounds right - (self cornerRadius * 3)) @ top
+ corner: (myBounds right - self cornerRadius)
+ @ (top + (self cornerRadius * 2)))
+ color: myColor.
+
+ myArcLengths := self arcLengths.
+ 1 to: myArcLengths size do: [ :i | | length |
+ length := myArcLengths at: i.
+ aCanvas line: (myBounds left + cornerRadius - i) @ (myBounds bottom - 1 )
+ to: (myBounds left + cornerRadius - i) @ (myBounds bottom - length - 1)
+ color: myColor.
+ aCanvas line: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - 1)
+ to: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - length - 1)
+ color: myColor]
+
+ !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>initialize (in category 'initialization') -----
+ initialize
+ ^ super initialize
+ !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>innerExtent: (in category 'access') -----
+ innerExtent: aPoint
+ "Set the extent based on the primary visible part of the tab. In other words add twice the cornerRadius to this extent"
+ self extent: (aPoint x + (self cornerRadius * 2)) @ (aPoint y)!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>model (in category 'access') -----
+ model
+ ^ model
+ !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>model: (in category 'access') -----
+ model: anObject
+ model := anObject!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>outerGap (in category 'access') -----
+ outerGap
+ "The horizontal distance of the outer left and right edges of the tab excluding the inner visible part"
+ ^ self cornerRadius * 2!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>step (in category 'stepping') -----
+ step
+ self subMorph step.
+ self changed.
+ !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>stepTime (in category 'stepping') -----
+ stepTime
+ ^ self subMorph stepTime
+ !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>subMorph (in category 'private - access') -----
+ subMorph
+ subMorph ifNil: [ self update: self textSelector ].
+ ^ subMorph!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>subMorph: (in category 'private - access') -----
+ subMorph: aMorph
+ subMorph := aMorph
+ !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>textSelector (in category 'access') -----
+ textSelector
+ ^ textSelector
+ !
Item was added:
+ ----- Method: PluggableTabButtonMorph>>textSelector: (in category 'access') -----
+ textSelector: aSymbol
+ textSelector := aSymbol!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>toggle (in category 'actions') -----
+ toggle
+ self active: self active not!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>topInactiveGap (in category 'private - access') -----
+ topInactiveGap
+ ^ 5!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>update: (in category 'updating') -----
+ update: aSelector
+ self textSelector ifNotNil: [
+ aSelector = self textSelector
+ ifTrue: [ | morph |
+ (aSelector isSymbol and: [model notNil])
+ ifTrue: [
+ morph :=
+ (self model perform: aSelector) asMorph]
+ ifFalse: [ morph := aSelector value asMorph].
+ self subMorph: morph]].
+ self changed!
Item was added:
+ ----- Method: PluggableTabButtonMorph>>wantsSteps (in category 'stepping') -----
+ wantsSteps
+ ^ self subMorph wantsSteps!
Item was added:
+ ScrollPane subclass: #PluggableTextMorph
+ instanceVariableNames: 'textMorph getTextSelector setTextSelector getSelectionSelector hasUnacceptedEdits askBeforeDiscardingEdits selectionInterval hasEditingConflicts editTextSelector'
+ classVariableNames: 'AdornmentCache SimpleFrameAdornments'
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
Item was added:
+ ----- Method: PluggableTextMorph class>>adornmentCache (in category 'frame adornments') -----
+ adornmentCache
+ "Cache for frame adornments"
+
+ ^AdornmentCache ifNil:[AdornmentCache := Dictionary new].!
Item was added:
+ ----- Method: PluggableTextMorph class>>adornmentWithColor: (in category 'frame adornments') -----
+ adornmentWithColor: aColor
+ "Create and return a frame adornment with the given color"
+
+ | size box form fillStyle |
+ ^self adornmentCache at: aColor ifAbsentPut:[
+ size := 25.
+ box := 0 at 0 extent: size asPoint.
+ form := Form extent: size at size depth: 32.
+ fillStyle := (GradientFillStyle ramp: {
+ 0.0->(Color white alpha: 0.01).
+ 0.8->aColor.
+ 1.0->aColor})
+ origin: box topRight - (size at 0);
+ direction: (size @ size negated) // 4;
+ radial: false.
+ form getCanvas drawPolygon: {
+ box topRight.
+ box topRight + (0 at size).
+ box topRight - (size at 0)
+ } fillStyle: fillStyle.
+ form].
+ !
Item was added:
+ ----- Method: PluggableTextMorph class>>flushAdornmentCache (in category 'frame adornments') -----
+ flushAdornmentCache
+ "Cache for frame adornments"
+
+ AdornmentCache := nil!
Item was added:
+ ----- Method: PluggableTextMorph class>>on:text:accept: (in category 'as yet unclassified') -----
+ on: anObject text: getTextSel accept: setTextSel
+
+ ^ self on: anObject
+ text: getTextSel
+ accept: setTextSel
+ readSelection: nil
+ menu: nil!
Item was added:
+ ----- Method: PluggableTextMorph class>>on:text:accept:readSelection:menu: (in category 'as yet unclassified') -----
+ on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel
+
+ ^ self new on: anObject
+ text: getTextSel
+ accept: setTextSel
+ readSelection: getSelectionSel
+ menu: getMenuSel!
Item was added:
+ ----- Method: PluggableTextMorph class>>simpleFrameAdornments (in category 'frame adornments') -----
+ simpleFrameAdornments
+ <preference: 'Simple Frame Adornments'
+ category: 'Morphic'
+ description: 'When true, use a simple rectangular feedback for indicating unsaved changes in text editors'
+ type: #Boolean>
+ ^SimpleFrameAdornments ifNil:[false]!
Item was added:
+ ----- Method: PluggableTextMorph class>>simpleFrameAdornments: (in category 'frame adornments') -----
+ simpleFrameAdornments: aBool
+ "Sets the simpleFrameAdornment preference
+ PluggableTextMorph simpleFrameAdornments: true.
+ PluggableTextMorph simpleFrameAdornments: false.
+ "
+ SimpleFrameAdornments := aBool
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>accept (in category 'menu commands') -----
+ accept
+ "Inform the model of text to be accepted, and return true if OK."
+
+ | ok saveSelection saveScrollerOffset |
+ "sps 8/13/2001 22:41: save selection and scroll info"
+ saveSelection := self selectionInterval copy.
+ saveScrollerOffset := scroller offset copy.
+
+ (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not])
+ ifTrue: [^ self flash].
+
+ self hasEditingConflicts ifTrue:
+ [(self confirm:
+ 'Caution!! This method may have been
+ changed elsewhere since you started
+ editing it here. Accept anyway?' translated) ifFalse: [^ self flash]].
+ ok := self acceptTextInModel.
+ ok==true ifTrue:
+ [self setText: self getText.
+ self hasUnacceptedEdits: false.
+ (model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) ifNotNil:
+ [:aPane | model changed: #annotation]].
+
+ "sps 8/13/2001 22:41: restore selection and scroll info"
+ ["During the step for the browser, updateCodePaneIfNeeded is called, and
+ invariably resets the contents of the codeholding PluggableTextMorph
+ at that time, resetting the cursor position and scroller in the process.
+ The following line forces that update without waiting for the step, then restores the cursor and scrollbar"
+
+ ok ifTrue: "(don't bother if there was an error during compile)"
+ [(model respondsTo: #updateCodePaneIfNeeded)
+ ifTrue: [model updateCodePaneIfNeeded].
+ WorldState addDeferredUIMessage:
+ [self currentHand newKeyboardFocus: textMorph.
+ scroller offset: saveScrollerOffset.
+ self setScrollDeltas.
+ selectionInterval := saveSelection. "restore prior selection"
+ self selectFrom: saveSelection first to: saveSelection last]]]
+
+ on: Error do: []
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>acceptDroppingMorph:event: (in category 'layout') -----
+ acceptDroppingMorph: aMorph event: evt
+ "This message is sent when a morph is dropped onto a morph that has
+ agreed to accept the dropped morph by responding 'true' to the
+ wantsDroppedMorph:Event: message. The default implementation just
+ adds the given morph to the receiver."
+ "Here we let the model do its work."
+
+ self model
+ acceptDroppingMorph: aMorph
+ event: evt
+ inMorph: self.
+
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>acceptOnCR: (in category 'initialization') -----
+ acceptOnCR: trueOrFalse
+ textMorph acceptOnCR: trueOrFalse!
Item was added:
+ ----- Method: PluggableTextMorph>>acceptTextInModel (in category 'menu commands') -----
+ acceptTextInModel
+ "Inform the model that the receiver's textMorph's text should be accepted.
+ Answer true if the model accepted ok, false otherwise"
+ | textToAccept |
+
+ textToAccept := textMorph asText.
+ ^setTextSelector isNil or:
+ [setTextSelector numArgs = 2
+ ifTrue: [model perform: setTextSelector with: textToAccept with: self]
+ ifFalse: [model perform: setTextSelector with: textToAccept]]
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>again (in category 'menu commands') -----
+ again
+ self handleEdit: [textMorph editor again]!
Item was added:
+ ----- Method: PluggableTextMorph>>appendEntry (in category 'transcript') -----
+ appendEntry
+ "Append the text in the model's writeStream to the editable text. "
+ textMorph asText size > model characterLimit ifTrue:
+ ["Knock off first half of text"
+ self selectInvisiblyFrom: 1 to: textMorph asText size // 2.
+ self replaceSelectionWith: Text new].
+ self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size.
+ self replaceSelectionWith: model contents asText.
+ self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size!
Item was added:
+ ----- Method: PluggableTextMorph>>askBeforeDiscardingEdits: (in category 'unaccepted edits') -----
+ askBeforeDiscardingEdits: aBoolean
+ "Set the flag that determines whether the user should be asked before discarding unaccepted edits."
+
+ askBeforeDiscardingEdits := aBoolean!
Item was added:
+ ----- Method: PluggableTextMorph>>browseChangeSetsWithSelector (in category 'menu commands') -----
+ browseChangeSetsWithSelector
+ "Help the user track down which change sets mention a particular selector"
+
+ self handleEdit: [textMorph editor browseChangeSetsWithSelector]!
Item was added:
+ ----- Method: PluggableTextMorph>>browseIt (in category 'menu commands') -----
+ browseIt
+ self handleEdit: [textMorph editor browseIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>bsText (in category 'transcript') -----
+ bsText
+ self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))!
Item was added:
+ ----- Method: PluggableTextMorph>>buttonForIt (in category 'menu commands') -----
+ buttonForIt
+ self handleEdit: [textMorph editor buttonForIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>canBeEncroached (in category 'testing') -----
+ canBeEncroached
+ "Fixed-height always report true, since they cannot be encroached."
+ self layoutFrame ifNotNil: [ : frame | frame topFraction = frame bottomFraction ifTrue: [ ^ true ] ].
+ ^ (textMorph height+10) < self height!
Item was added:
+ ----- Method: PluggableTextMorph>>canDiscardEdits (in category 'dependents access') -----
+ canDiscardEdits
+ "Return true if this view either has no text changes or does not care."
+
+ ^ (hasUnacceptedEdits & askBeforeDiscardingEdits) not
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>cancel (in category 'menu commands') -----
+ cancel
+ self setText: self getText.
+ self setSelection: self getSelection.
+ getTextSelector == #annotation ifFalse:
+ [(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) ifNotNil:
+ [:aPane | model changed: #annotation]]!
Item was added:
+ ----- Method: PluggableTextMorph>>changeStyle (in category 'menu commands') -----
+ changeStyle
+ self handleEdit: [textMorph editor changeStyle]!
Item was added:
+ ----- Method: PluggableTextMorph>>changeText: (in category 'transcript') -----
+ changeText: aText
+ "The paragraph to be edited is changed to aText."
+ self setText: aText!
Item was added:
+ ----- Method: PluggableTextMorph>>charactersOccluded (in category 'geometry') -----
+ charactersOccluded
+ "Let the receiver suggest to its neighboring vertical Splitter(s) that they try to optimize their position such that none of the receivers lines need to wrap."
+ | numberOfLogicalLines numberOfPhysicalLines |
+ numberOfLogicalLines := self text lineCount.
+ numberOfPhysicalLines:= textMorph paragraph numberOfLines.
+ ^ numberOfPhysicalLines - numberOfLogicalLines!
Item was added:
+ ----- Method: PluggableTextMorph>>chooseAlignment (in category 'menu commands') -----
+ chooseAlignment
+ self handleEdit: [textMorph editor changeAlignment]!
Item was added:
+ ----- Method: PluggableTextMorph>>classCommentsContainingIt (in category 'menu commands') -----
+ classCommentsContainingIt
+ self handleEdit: [textMorph editor classCommentsContainingIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>classNamesContainingIt (in category 'menu commands') -----
+ classNamesContainingIt
+ self handleEdit: [textMorph editor classNamesContainingIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>copyHtml (in category 'html') -----
+ copyHtml
+ "put the html representation of the receiver's text into the clipboard"
+ Clipboard clipboardText: self text printHtmlString!
Item was added:
+ ----- Method: PluggableTextMorph>>copySelection (in category 'menu commands') -----
+ copySelection
+ self handleEdit: [textMorph editor copySelection]!
Item was added:
+ ----- Method: PluggableTextMorph>>correctFrom:to:with: (in category 'interactive error protocol') -----
+ correctFrom: start to: stop with: aString
+ ^ self handleEdit: [textMorph editor correctFrom: start to: stop with: aString]!
Item was added:
+ ----- Method: PluggableTextMorph>>correctSelectionWithString: (in category 'interactive error protocol') -----
+ correctSelectionWithString: aString
+ | result newPosition |
+
+ "I can't tell if this is a hack or if it's the right thing to do."
+ self setSelection: selectionInterval.
+
+ result := self correctFrom: selectionInterval first to: selectionInterval last with: aString.
+ newPosition := selectionInterval first + aString size.
+ self setSelection: (newPosition to: newPosition - 1).
+ ^ result!
Item was added:
+ ----- Method: PluggableTextMorph>>cut (in category 'menu commands') -----
+ cut
+ self handleEdit: [textMorph editor cut]!
Item was added:
+ ----- Method: PluggableTextMorph>>debugIt (in category 'menu commands') -----
+ debugIt
+ self handleEdit: [textMorph editor debugIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>deselect (in category 'interactive error protocol') -----
+ deselect
+ ^ textMorph editor deselect!
Item was added:
+ ----- Method: PluggableTextMorph>>doIt (in category 'menu commands') -----
+ doIt
+ ^self handleEdit: [textMorph editor evaluateSelection]!
Item was added:
+ ----- Method: PluggableTextMorph>>drawFrameAdornment:on: (in category 'drawing') -----
+ drawFrameAdornment: aColor on: aCanvas
+ "Indicate edit status for the text editor"
+ self class simpleFrameAdornments
+ ifTrue:
+ [ aCanvas
+ frameRectangle: self innerBounds
+ width: 1
+ color: aColor.
+ aCanvas
+ frameRectangle: (self innerBounds insetBy: 1)
+ width: 1
+ color: (aColor alpha: aColor alpha / 3.0) ]
+ ifFalse:
+ [ | form |
+ "Class-side adornment cache is currently using pre-multiplied alpha, so we need to use rule 34 which works for < 32bpp, too."
+ form := self class adornmentWithColor: aColor.
+ aCanvas
+ image: form
+ at: self innerBounds topRight - (form width @ 0)
+ sourceRect: form boundingBox
+ rule: 34 ]!
Item was added:
+ ----- Method: PluggableTextMorph>>drawFrameAdornmentsOn: (in category 'drawing') -----
+ drawFrameAdornmentsOn: aCanvas
+ "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame"
+
+ self wantsFrameAdornments ifTrue:
+ [(model notNil and: [model refusesToAcceptCode])
+ ifTrue: "Put up feedback showing that code cannot be submitted in this state"
+ [self drawFrameAdornment: Color tan on: aCanvas]
+ ifFalse:
+ [self hasEditingConflicts
+ ifTrue:
+ [self drawFrameAdornment: Color red on: aCanvas]
+ ifFalse:
+ [self hasUnacceptedEdits
+ ifTrue:
+ [model wantsDiffFeedback
+ ifTrue:
+ [self drawFrameAdornment: Color yellow on: aCanvas]
+ ifFalse:
+ [self drawFrameAdornment: Color orange on: aCanvas]]
+ ifFalse:
+ [model wantsDiffFeedback
+ ifTrue:
+ [self drawFrameAdornment: Color green on: aCanvas]]]]]!
Item was added:
+ ----- Method: PluggableTextMorph>>editString: (in category 'initialization') -----
+ editString: aString
+ "Jam some text in. This is treated as clean text by default."
+
+ self setText: aString asText!
Item was added:
+ ----- Method: PluggableTextMorph>>editTextSelector (in category 'accessing') -----
+ editTextSelector
+
+ ^ editTextSelector!
Item was added:
+ ----- Method: PluggableTextMorph>>editTextSelector: (in category 'accessing') -----
+ editTextSelector: aSymbol
+
+ editTextSelector := aSymbol.!
Item was added:
+ ----- Method: PluggableTextMorph>>explain (in category 'menu commands') -----
+ explain
+ self handleEdit: [textMorph editor explain]!
Item was added:
+ ----- Method: PluggableTextMorph>>exploreIt (in category 'menu commands') -----
+ exploreIt
+
+
+ self handleEdit:
+ [textMorph editor evaluateSelectionAndDo: [:result | result explore]].!
Item was added:
+ ----- Method: PluggableTextMorph>>extent: (in category 'geometry') -----
+ extent: newExtent
+
+ bounds extent = newExtent ifTrue: [^ self].
+ super extent: (newExtent max: 36 at 16).
+ self setScrollDeltas
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>extraScrollRange (in category 'geometry') -----
+ extraScrollRange
+ ^ self height // 4!
Item was added:
+ ----- Method: PluggableTextMorph>>fileItIn (in category 'menu commands') -----
+ fileItIn
+ self handleEdit: [textMorph editor fileItIn]!
Item was added:
+ ----- Method: PluggableTextMorph>>find (in category 'menu commands') -----
+ find
+ self handleEdit: [textMorph editor find]!
Item was added:
+ ----- Method: PluggableTextMorph>>findAgain (in category 'menu commands') -----
+ findAgain
+ self handleEdit: [textMorph editor findAgain]!
Item was added:
+ ----- Method: PluggableTextMorph>>font: (in category 'initialization') -----
+ font: aFont
+ textMorph beAllFont: aFont!
Item was added:
+ ----- Method: PluggableTextMorph>>fullDrawOn: (in category 'drawing') -----
+ fullDrawOn: aCanvas
+ "Draw frame adornments on top of everything otherwise they will partially overlap with text selection which looks ugly."
+ super fullDrawOn: aCanvas.
+ self drawFrameAdornmentsOn: aCanvas.
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>getSelection (in category 'model access') -----
+ getSelection
+ "Answer the model's selection interval."
+
+ getSelectionSelector ifNil: [^1 to: 0]. "null selection"
+ ^model perform: getSelectionSelector!
Item was added:
+ ----- Method: PluggableTextMorph>>getText (in category 'model access') -----
+ getText
+ "Retrieve the current model text"
+
+ | newText |
+ getTextSelector ifNil: [^Text new].
+ newText := model perform: getTextSelector.
+ newText ifNil: [^Text new].
+ ^newText shallowCopy!
Item was added:
+ ----- Method: PluggableTextMorph>>getTextSelector (in category 'accessing') -----
+ getTextSelector
+ ^getTextSelector!
Item was added:
+ ----- Method: PluggableTextMorph>>handleEdit: (in category 'editor access') -----
+ handleEdit: editBlock
+ | result |
+ textMorph editor selectFrom: selectionInterval first to: selectionInterval last;
+ model: model. "For, eg, evaluateSelection"
+ result := textMorph handleEdit: editBlock. "Update selection after edit"
+ self scrollSelectionIntoView.
+ ^ result!
Item was added:
+ ----- Method: PluggableTextMorph>>hasEditingConflicts (in category 'unaccepted edits') -----
+ hasEditingConflicts
+ "Return true if a conflicting edit to the same code (typically) is known to have occurred after the current contents started getting edited"
+
+ ^ hasEditingConflicts == true!
Item was added:
+ ----- Method: PluggableTextMorph>>hasEditingConflicts: (in category 'unaccepted edits') -----
+ hasEditingConflicts: aBoolean
+
+ hasEditingConflicts := aBoolean!
Item was added:
+ ----- Method: PluggableTextMorph>>hasUnacceptedEdits (in category 'dependents access') -----
+ hasUnacceptedEdits
+ "Return true if this view has unaccepted edits."
+
+ ^ hasUnacceptedEdits!
Item was added:
+ ----- Method: PluggableTextMorph>>hasUnacceptedEdits: (in category 'unaccepted edits') -----
+ hasUnacceptedEdits: aBoolean
+ "Set the hasUnacceptedEdits flag to the given value. "
+ aBoolean == hasUnacceptedEdits ifFalse:
+ [hasUnacceptedEdits := aBoolean.
+ self changed].
+ aBoolean ifFalse: [hasEditingConflicts := false]!
Item was added:
+ ----- Method: PluggableTextMorph>>implementorsOfIt (in category 'menu commands') -----
+ implementorsOfIt
+ self handleEdit: [textMorph editor implementorsOfIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ hasUnacceptedEdits := false.
+ hasEditingConflicts := false.
+ askBeforeDiscardingEdits := true.
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>inspectIt (in category 'menu commands') -----
+ inspectIt
+
+ self handleEdit:
+ [textMorph editor evaluateSelectionAndDo: [:result | result inspect]]!
Item was added:
+ ----- Method: PluggableTextMorph>>installModelIn: (in category 'debug and other') -----
+ installModelIn: aWorld
+ "No special inits for new components"
+ ^ self!
Item was added:
+ ----- Method: PluggableTextMorph>>isTextView (in category 'testing') -----
+ isTextView
+ "True if the reciever is a view on a text model, such as a view on a TranscriptStream"
+ ^true!
Item was added:
+ ----- Method: PluggableTextMorph>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+ "A keystroke was hit while the receiver had keyboard focus. Pass the keystroke on to my textMorph, and and also, if I have an event handler, pass it on to that handler"
+
+ textMorph keyStroke: evt.
+ self eventHandler ifNotNil:
+ [self eventHandler keyStroke: evt fromMorph: self].
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>keyboardFocusDelegate (in category 'event handling') -----
+ keyboardFocusDelegate
+
+ ^ textMorph ifNil: [self]!
Item was added:
+ ----- Method: PluggableTextMorph>>methodNamesContainingIt (in category 'menu commands') -----
+ methodNamesContainingIt
+ self handleEdit: [textMorph editor methodNamesContainingIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>methodSourceContainingIt (in category 'menu commands') -----
+ methodSourceContainingIt
+ self handleEdit: [textMorph editor methodSourceContainingIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>methodStringsContainingit (in category 'menu commands') -----
+ methodStringsContainingit
+ self handleEdit: [textMorph editor methodStringsContainingit]!
Item was added:
+ ----- Method: PluggableTextMorph>>mouseEnter: (in category 'event handling') -----
+ mouseEnter: event
+ super mouseEnter: event.
+ selectionInterval ifNotNil:
+ [textMorph editor selectInterval: selectionInterval; setEmphasisHere].
+ textMorph selectionChanged.
+ Preferences mouseOverForKeyboardFocus ifTrue:[
+ event hand newKeyboardFocus: textMorph]!
Item was added:
+ ----- Method: PluggableTextMorph>>mouseLeave: (in category 'event handling') -----
+ mouseLeave: event
+ "The mouse has left the area of the receiver"
+
+ textMorph ifNotNil: [selectionInterval := textMorph editor selectionInterval].
+ super mouseLeave: event.
+ Preferences mouseOverForKeyboardFocus ifTrue:
+ [event hand releaseKeyboardFocus: textMorph]!
Item was added:
+ ----- Method: PluggableTextMorph>>nextTokenFrom:direction: (in category 'interactive error protocol') -----
+ nextTokenFrom: start direction: dir
+ ^ textMorph editor nextTokenFrom: start direction: dir!
Item was added:
+ ----- Method: PluggableTextMorph>>notify:at:in: (in category 'interactive error protocol') -----
+ notify: aString at: anInteger in: aStream
+ ^ textMorph editor notify: aString at: anInteger in: aStream!
Item was added:
+ ----- Method: PluggableTextMorph>>offerFontMenu (in category 'menu commands') -----
+ offerFontMenu
+ self handleEdit: [textMorph editor changeTextFont]!
Item was added:
+ ----- Method: PluggableTextMorph>>on:text:accept:readSelection:menu: (in category 'initialization') -----
+ on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel
+
+ self model: anObject.
+ getTextSelector := getTextSel.
+ setTextSelector := setTextSel.
+ getSelectionSelector := getSelectionSel.
+ getMenuSelector := getMenuSel.
+ self borderWidth: 1.
+ self setText: self getText.
+ self setSelection: self getSelection.!
Item was added:
+ ----- Method: PluggableTextMorph>>onKeyStrokeSend:to: (in category 'event handling') -----
+ onKeyStrokeSend: sel to: recipient
+ textMorph on: #keyStroke send: sel to: recipient.!
Item was added:
+ ----- Method: PluggableTextMorph>>paste (in category 'menu commands') -----
+ paste
+ self handleEdit: [textMorph editor paste]!
Item was added:
+ ----- Method: PluggableTextMorph>>pasteRecent (in category 'menu commands') -----
+ pasteRecent
+ "Paste an item chosen from RecentClippings."
+
+ | clipping |
+ (clipping := Clipboard chooseRecentClipping) ifNil: [^ self].
+ Clipboard clipboardText: clipping.
+ ^ self handleEdit: [textMorph editor paste]!
Item was added:
+ ----- Method: PluggableTextMorph>>presentSpecialMenu (in category 'menu commands') -----
+ presentSpecialMenu
+ self handleEdit: [textMorph editor presentSpecialMenu]!
Item was added:
+ ----- Method: PluggableTextMorph>>prettyPrint (in category 'menu commands') -----
+ prettyPrint
+ self handleEdit: [textMorph editor prettyPrint]!
Item was added:
+ ----- Method: PluggableTextMorph>>prettyPrintWithColor (in category 'menu commands') -----
+ prettyPrintWithColor
+ self handleEdit: [textMorph editor prettyPrintWithColor]!
Item was added:
+ ----- Method: PluggableTextMorph>>printIt (in category 'menu commands') -----
+ printIt
+ | oldEditor |
+ textMorph editor selectFrom: selectionInterval first to: selectionInterval last;
+ model: model. "For, eg, evaluateSelection"
+ textMorph handleEdit: [(oldEditor := textMorph editor) evaluateSelectionAndDo:
+ [:result |
+ selectionInterval := oldEditor selectionInterval.
+ textMorph installEditorToReplace: oldEditor.
+ textMorph handleEdit: [oldEditor afterSelectionInsertAndSelect: result printString].
+ selectionInterval := oldEditor selectionInterval.
+
+ textMorph editor selectFrom: selectionInterval first to: selectionInterval last.
+ self scrollSelectionIntoView]]!
Item was added:
+ ----- Method: PluggableTextMorph>>printerSetup (in category 'menu commands') -----
+ printerSetup
+ self handleEdit: [textMorph editor printerSetup]!
Item was added:
+ ----- Method: PluggableTextMorph>>promptForCancel (in category 'unaccepted edits') -----
+ promptForCancel
+ "Ask if it is OK to cancel changes to text"
+ (self confirm:
+ 'Changes have not been saved.
+ Is it OK to cancel those changes?' translated)
+ ifTrue: [model clearUserEditFlag].
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>referencesToIt (in category 'menu commands') -----
+ referencesToIt
+ self handleEdit: [textMorph editor referencesToIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>replaceSelectionWith: (in category 'transcript') -----
+ replaceSelectionWith: aText
+ ^ textMorph editor replaceSelectionWith: aText!
Item was added:
+ ----- Method: PluggableTextMorph>>resetExtent (in category 'geometry') -----
+ resetExtent
+ "Reset the extent while maintaining the current selection. Needed when resizing while the editor is active (when inside the pane)."
+ | tempSelection |
+ textMorph notNil ifTrue:
+ ["the current selection gets munged by resetting the extent, so store it"
+ tempSelection := self selectionInterval.
+
+ "don't reset it if it's not active"
+ tempSelection = (Interval from: 1 to: 0)
+ ifTrue: [retractableScrollBar
+ ifTrue:[ ^ self]].
+ self extent: self extent.
+ self setSelection: tempSelection].
+ super resetExtent.!
Item was added:
+ ----- Method: PluggableTextMorph>>resizeScroller (in category 'geometry') -----
+ resizeScroller
+ "Also needs to resize the text morph"
+
+ super resizeScroller.
+
+ textMorph ifNotNil: [:tm |
+ tm isAutoFit ifTrue: [textMorph extent: self scroller extent]].!
Item was added:
+ ----- Method: PluggableTextMorph>>saveContentsInFile (in category 'menu commands') -----
+ saveContentsInFile
+ self handleEdit: [textMorph editor saveContentsInFile]!
Item was added:
+ ----- Method: PluggableTextMorph>>scrollBarMenuButtonPressed: (in category 'scroll bar events') -----
+ scrollBarMenuButtonPressed: event
+ "The menu button in the scrollbar was pressed; put up the menu"
+
+ | menu |
+ (menu := self getMenu: event shiftPressed) ifNotNil:
+ ["Set up to use perform:orSendTo: for model/view dispatch"
+ menu setInvokingView: self.
+ menu invokeModal]!
Item was added:
+ ----- Method: PluggableTextMorph>>scrollDeltaHeight (in category 'geometry') -----
+ scrollDeltaHeight
+ "Return the increment in pixels which this pane should be scrolled."
+ ^ textMorph ifNil: [super scrollDeltaHeight] ifNotNil: [:tm | tm defaultLineHeight]
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>scrollSelectionIntoView (in category 'editor access') -----
+ scrollSelectionIntoView
+ "Scroll my text into view if necessary and return true, else return false"
+ ^ self scrollSelectionIntoView: nil!
Item was added:
+ ----- Method: PluggableTextMorph>>scrollSelectionIntoView: (in category 'editor access') -----
+ scrollSelectionIntoView: event
+ "Scroll my text into view if necessary and return true, else return false"
+ | selRects rectToTest transform cpHere |
+ selectionInterval := textMorph editor selectionInterval.
+ selRects := textMorph paragraph selectionRects.
+ selRects isEmpty ifTrue: [^ false].
+ rectToTest := selRects reduce: [:r1 :r2 | r1 quickMerge: r2].
+ transform := scroller transformFrom: self.
+ (event notNil and: [event anyButtonPressed]) ifTrue: "Check for autoscroll"
+ [cpHere := transform localPointToGlobal: event cursorPoint.
+ cpHere y <= self top
+ ifTrue: [rectToTest := selRects first topLeft extent: 2 at 2]
+ ifFalse: [cpHere y >= self bottom
+ ifTrue: [rectToTest := selRects last bottomRight extent: 2 at 2]
+ ifFalse: [^ false]]].
+ self scrollToShow: rectToTest.
+ self scrollToShow: textMorph editor pointBlock. "Ensure text cursor visibility."
+ ^ true!
Item was added:
+ ----- Method: PluggableTextMorph>>select (in category 'interactive error protocol') -----
+ select
+ ^ textMorph editor select!
Item was added:
+ ----- Method: PluggableTextMorph>>selectAll (in category 'editor access') -----
+ selectAll
+ "Tell my textMorph's editor to select all"
+
+ textMorph editor selectAll!
Item was added:
+ ----- Method: PluggableTextMorph>>selectFrom:to: (in category 'interactive error protocol') -----
+ selectFrom: start to: stop
+ ^ textMorph editor selectFrom: start to: stop!
Item was added:
+ ----- Method: PluggableTextMorph>>selectInvisiblyFrom:to: (in category 'interactive error protocol') -----
+ selectInvisiblyFrom: start to: stop
+ ^ textMorph editor selectInvisiblyFrom: start to: stop!
Item was added:
+ ----- Method: PluggableTextMorph>>selectionInterval (in category 'interactive error protocol') -----
+ selectionInterval
+ ^ textMorph editor selectionInterval!
Item was added:
+ ----- Method: PluggableTextMorph>>selectionInterval: (in category 'model access') -----
+ selectionInterval: sel
+ selectionInterval := sel!
Item was added:
+ ----- Method: PluggableTextMorph>>sendContentsToPrinter (in category 'menu commands') -----
+ sendContentsToPrinter
+ self handleEdit: [textMorph editor sendContentsToPrinter]!
Item was added:
+ ----- Method: PluggableTextMorph>>sendersOfIt (in category 'menu commands') -----
+ sendersOfIt
+ self handleEdit: [textMorph editor sendersOfIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>setSearchString (in category 'menu commands') -----
+ setSearchString
+ self handleEdit: [textMorph editor setSearchString]!
Item was added:
+ ----- Method: PluggableTextMorph>>setSelection: (in category 'model access') -----
+ setSelection: sel
+ selectionInterval := sel.
+ textMorph editor selectFrom: sel first to: sel last.
+ self scrollSelectionIntoView ifFalse: [scroller changed].!
Item was added:
+ ----- Method: PluggableTextMorph>>setText: (in category 'model access') -----
+ setText: aText
+ textMorph
+ ifNil: [textMorph := self textMorphClass new
+ contents: aText
+ wrappedTo: self innerBounds width.
+ textMorph
+ margins: (3 at 0 corner: 0 at 0);
+ setEditView: self;
+ setProperty: #indicateKeyboardFocus toValue: #never.
+ scroller addMorph: textMorph]
+ ifNotNil: [textMorph newContents: aText].
+ self hasUnacceptedEdits: false.
+ self setScrollDeltas.!
Item was added:
+ ----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
+ setTextColor: aColor
+ "Set the color of my text to the given color"
+
+ textMorph color: aColor!
Item was added:
+ ----- Method: PluggableTextMorph>>setTextMorphToSelectAllOnMouseEnter (in category 'editor access') -----
+ setTextMorphToSelectAllOnMouseEnter
+ "Tell my textMorph's editor to select all when the mouse enters"
+
+ textMorph on: #mouseEnter send: #selectAll to: textMorph!
Item was added:
+ ----- Method: PluggableTextMorph>>spawn (in category 'menu commands') -----
+ spawn
+ self handleEdit: [textMorph editor spawn].
+ self cancel!
Item was added:
+ ----- Method: PluggableTextMorph>>spyOnIt (in category 'menu commands') -----
+ spyOnIt
+ self handleEdit: [textMorph editor spyOnIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>tallyIt (in category 'menu commands') -----
+ tallyIt
+ self handleEdit: [textMorph editor tallyIt]!
Item was added:
+ ----- Method: PluggableTextMorph>>text (in category 'model access') -----
+ text
+ ^ textMorph contents!
Item was added:
+ ----- Method: PluggableTextMorph>>textEdited: (in category 'editor access') -----
+ textEdited: someText
+ "Tell the model about some edits in the text if interested. This is not #accept, which means that it will be send on every keystroke."
+
+ self editTextSelector ifNotNil: [:selector |
+ model perform: selector with: someText].!
Item was added:
+ ----- Method: PluggableTextMorph>>textMorph (in category 'accessing') -----
+ textMorph
+ ^ textMorph!
Item was added:
+ ----- Method: PluggableTextMorph>>textMorphClass (in category 'private') -----
+ textMorphClass
+ "Answer the class used to create the receiver's textMorph"
+
+ ^TextMorphForEditView!
Item was added:
+ ----- Method: PluggableTextMorph>>tileForIt (in category 'menu commands') -----
+ tileForIt
+ "Return a tile referring to the object resulting form evaluating my current selection. Not currently threaded in, but useful in earlier demos and possibly still of value."
+
+
+ self handleEdit:
+ [textMorph editor evaluateSelectionAndDo: [:result | self currentHand attachMorph: result tileToRefer]]!
Item was added:
+ ----- Method: PluggableTextMorph>>toggleAnnotationPaneSize (in category 'menu commands') -----
+ toggleAnnotationPaneSize
+
+ | handle origin aHand siblings |
+
+ self flag: #bob. "CRUDE HACK to enable changing the size of the annotations pane"
+
+ owner ifNil: [^self].
+ siblings := owner submorphs.
+ siblings size > 3 ifTrue: [^self].
+ siblings size < 2 ifTrue: [^self].
+
+ aHand := self primaryHand.
+ origin := aHand position.
+ (handle := HandleMorph new)
+ forEachPointDo: [:newPoint | | lf ht prevBottom newHeight m |
+ handle removeAllMorphs.
+ newHeight := (newPoint - origin) y asInteger min: owner height - 50 max: 16.
+ lf := siblings last layoutFrame.
+ lf bottomOffset: newHeight.
+ prevBottom := newHeight.
+ siblings size - 1 to: 1 by: -1 do: [ :index |
+ m := siblings at: index.
+ lf := m layoutFrame.
+ ht := lf bottomOffset - lf topOffset.
+ lf topOffset: prevBottom.
+ lf bottomOffset = 0 ifFalse: [
+ lf bottomOffset: (prevBottom + ht).
+ ].
+ prevBottom := prevBottom + ht.
+ ].
+ owner layoutChanged.
+
+ ]
+ lastPointDo:
+ [:newPoint | handle deleteBalloon.
+ self halo ifNotNil: [:halo | halo addHandles].
+ ].
+ aHand attachMorph: handle.
+ handle setProperty: #helpAtCenter toValue: true.
+ handle showBalloon:
+ 'Move cursor farther from
+ this point to increase pane.
+ Click when done.' hand: aHand.
+ handle startStepping
+
+ !
Item was added:
+ ----- Method: PluggableTextMorph>>undo (in category 'menu commands') -----
+ undo
+ self handleEdit: [textMorph editor undo]!
Item was added:
+ ----- Method: PluggableTextMorph>>update: (in category 'updating') -----
+ update: aSymbol
+ aSymbol ifNil: [^self].
+ aSymbol == #flash ifTrue: [^self flash].
+ aSymbol == getTextSelector
+ ifTrue: [
+ self setText: self getText.
+ getSelectionSelector
+ ifNotNil: [self setSelection: self getSelection].
+ ^ self].
+ aSymbol == getSelectionSelector
+ ifTrue: [^self setSelection: self getSelection].
+ (aSymbol == #autoSelect and: [getSelectionSelector notNil])
+ ifTrue:
+ [self handleEdit:
+ [(textMorph editor)
+ abandonChangeText; "no replacement!!"
+ setSearch: model autoSelectString;
+ againOrSame: true]].
+ aSymbol == #clearUserEdits ifTrue: [^self hasUnacceptedEdits: false].
+ aSymbol == #wantToChange
+ ifTrue:
+ [self canDiscardEdits ifFalse: [^self promptForCancel].
+ ^self].
+ aSymbol == #appendEntry
+ ifTrue:
+ [self handleEdit: [self appendEntry].
+ ^self refreshWorld].
+ aSymbol == #clearText
+ ifTrue:
+ [self handleEdit: [self changeText: Text new].
+ ^self refreshWorld].
+ aSymbol == #bs
+ ifTrue:
+ [self handleEdit: [self bsText].
+ ^self refreshWorld].
+ aSymbol == #codeChangedElsewhere
+ ifTrue:
+ [self hasEditingConflicts: true.
+ ^self changed].
+ aSymbol == #saveContents
+ ifTrue:
+ [^self saveContentsInFile]!
Item was added:
+ ----- Method: PluggableTextMorph>>update:with: (in category 'updating') -----
+ update: aSymbol with: arg1
+ aSymbol == #editString ifTrue:[
+ self editString: arg1.
+ self hasUnacceptedEdits: true.
+ ].
+ ^super update: aSymbol with: arg1!
Item was added:
+ ----- Method: PluggableTextMorph>>wantsBalloon (in category 'halos and balloon help') -----
+ wantsBalloon
+
+ ^ self textMorph contents notEmpty and: [super wantsBalloon]!
Item was added:
+ ----- Method: PluggableTextMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
+ wantsDroppedMorph: aMorph event: anEvent
+ ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self!
Item was added:
+ ----- Method: PluggableTextMorph>>wantsFrameAdornments (in category 'drawing') -----
+ wantsFrameAdornments
+ "Answer whether the receiver wishes to have red borders, etc.,
+ used to show editing state"
+ "A 'long-term temporary workaround': a nonmodular,
+ unsavory, but expedient way to get the desired effect, sorry.
+ Clean up someday."
+ ^ self
+ valueOfProperty: #wantsFrameAdornments
+ ifAbsent: [(#(#annotation #searchString #infoViewContents ) includes: getTextSelector) not]!
Item was added:
+ ----- Method: PluggableTextMorph>>wantsFrameAdornments: (in category 'drawing') -----
+ wantsFrameAdornments: aBoolean
+ self setProperty: #wantsFrameAdornments toValue: aBoolean!
Item was added:
+ ----- Method: PluggableTextMorph>>yellowButtonActivity (in category 'menu commands') -----
+ yellowButtonActivity
+ "Called when the shifted-menu's 'more' item is chosen"
+ self yellowButtonActivity: false!
Item was added:
+ ----- Method: PluggableTextMorph>>yellowButtonActivity: (in category 'menu commands') -----
+ yellowButtonActivity: shiftKeyState
+ "Called when the shifted-menu's 'more' item is chosen"
+ | menu |
+ (menu := self getMenu: shiftKeyState)
+ ifNotNil: [""
+ menu setInvokingView: self.
+ menu invokeModal]!
Item was added:
+ PluggableTextMorph subclass: #PluggableTextMorphWithModel
+ instanceVariableNames: 'myContents'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Pluggable Widgets'!
Item was added:
+ ----- Method: PluggableTextMorphWithModel class>>authoringPrototype (in category 'scripting') -----
+ authoringPrototype
+ "Answer an instance of the receiver suitable for placing in a parts bin"
+
+ | proto |
+ proto := super authoringPrototype.
+ proto color: (Color r: 0.972 g: 0.972 b: 0.662).
+ ^ proto!
Item was added:
+ ----- Method: PluggableTextMorphWithModel>>delete (in category 'submorphs-add/remove') -----
+ delete
+ "Delete the receiver. Since I have myself as a dependent, I need to remove it. which is odd in itself. Also, the release of dependents will seemingly not be done if the *container* of the receiver is deleted rather than the receiver itself, a further problem"
+
+ self removeDependent: self.
+ super delete!
Item was added:
+ ----- Method: PluggableTextMorphWithModel>>getMyText (in category 'contents') -----
+ getMyText
+ ^myContents!
Item was added:
+ ----- Method: PluggableTextMorphWithModel>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ self
+ on: self
+ text: #getMyText
+ accept: #setMyText:
+ readSelection: nil
+ menu: nil!
Item was added:
+ ----- Method: PluggableTextMorphWithModel>>newTextContents: (in category 'contents') -----
+ newTextContents: stringOrText
+ "Accept new text contents."
+
+ | newText myText |
+ "Just underway; trying to make this work like TextMorph does, but not quite there yet."
+
+ newText := stringOrText asText.
+ (myText := textMorph text) = newText ifTrue: [^ self]. "No substantive change"
+
+ self world ifNotNil:
+ [self world startSteppingSubmorphsOf: self ].
+ !
Item was added:
+ ----- Method: PluggableTextMorphWithModel>>setMyText: (in category 'contents') -----
+ setMyText: someText
+ myContents := someText.
+ ^true.!
Item was added:
+ ----- Method: Point>>ceiling (in category '*Morphic-Truncation and Roundoff') -----
+ ceiling
+ "Answer a Point that is the receiver's x and y ceiling. Answer the receiver if its coordinates are already integral."
+
+ (x isInteger and: [y isInteger]) ifTrue: [^ self].
+ ^ x ceiling @ y ceiling
+ !
Item was added:
+ ----- Method: Point>>floor (in category '*Morphic-Truncation and Roundoff') -----
+ floor
+ "Answer a Point that is the receiver's x and y floor. Answer the receiver if its coordinates are already integral."
+
+ (x isInteger and: [y isInteger]) ifTrue: [^ self].
+ ^ x floor @ y floor
+ !
Item was added:
+ ----- Method: Point>>guarded (in category '*Morphic-extent functions') -----
+ guarded
+ "Return a positive nonzero extent."
+ self max: 1 at 1 .!
Item was added:
+ ----- Method: Point>>isIntegerPoint (in category '*Morphic-Truncation and Roundoff') -----
+ isIntegerPoint
+ ^ x isInteger and: [ y isInteger ] !
Item was added:
+ ----- Method: Point>>roundDownTo: (in category '*Morphic-Truncation and Roundoff') -----
+ roundDownTo: grid
+ "Answer a Point that is the receiver's x and y rounded to grid x and
+ grid y by lower value (toward negative infinity)."
+
+ | gridPoint |
+ gridPoint := grid asPoint.
+ ^(x roundDownTo: gridPoint x) @ (y roundDownTo: gridPoint y)!
Item was added:
+ ----- Method: Point>>roundUpTo: (in category '*Morphic-Truncation and Roundoff') -----
+ roundUpTo: grid
+ "Answer a Point that is the receiver's x and y rounded to grid x and
+ grid y by upper value (toward infinity)."
+
+ | gridPoint |
+ gridPoint := grid asPoint.
+ ^(x roundUpTo: gridPoint x) @ (y roundUpTo: gridPoint y)!
Item was added:
+ ----- Method: Point>>scaleTo: (in category '*Morphic-extent functions') -----
+ scaleTo: anExtent
+ "Return a Point scalefactor for shrinking a thumbnail of the receiver's extent to fit within anExtent"
+ " self and anExtent are expected to have positive nonZero x and y. "
+ | factor sX sY |
+ factor := 3.0 reciprocal . "EccentricityThreshhold reciprical"
+ sX := anExtent x / self x asFloat .
+ sY := anExtent y / self y asFloat .
+ sX = sY ifTrue: [ ^ sX @ sY ] . "Same aspect ratio"
+ ^ sX < sY ifTrue: [ sX @ (sX max: sY * factor) ]
+ ifFalse: [ (sY max: sX * factor ) @ sY ] !
Item was added:
+ BorderedMorph subclass: #PolygonMorph
+ instanceVariableNames: 'vertices closed filledForm arrows arrowForms smoothCurve curveState borderDashSpec handles borderForm'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !PolygonMorph commentStamp: 'md 2/24/2006 20:34' prior: 0!
+ This class implements a morph which can behave as four different objects depending on the the following two facts:
+ - is it OPEN or CLOSED?
+ - is it SEGMENTED or SMOOTHED.
+
+ 1. The OPEN and SEGMENTED variant looks like polyline.
+
+ 2. The OPEN and SMOOTHED variant looks like spline (kind of curve)
+
+ 3. The CLOSED and SEGMENTED variant looks like polygon. This is actually what you get when you do
+ PolygonMorph new openInWorld
+ You get a triangle. See below how to manipulate these objects...
+
+ 4. The CLOSED and SMOOTHED variant looks like blob (???)
+
+ Prototypes of this morph can also be found in "Object Catalog". Several (different variants) of this object are among "Basic" morphs.
+
+ Explore the assiciated morph-menu. It enables you
+ - to toggle showing of "handles". They make it possible to
+ - reposition already existing vertices (by moving yellow handles)
+ - create new vertices (by moving green handles)
+ - delete already existing vertices (by dragging and dropping one yellow handle closely
+ nearby the adjacent yellow handle
+ Handles can be made visible/hidden by shift+leftclicking the morph. This way it is possible
+ to quickly show handles, adjust vertices and then again hide handles.
+ - making closed polygon open, i.e. converting it to a curve (and vice versa)
+ - toggle smoothed/segmented line/outline
+ - set up custom dashing (for line, curves or borders of closed polygons
+ - set up custom arrow-heads (for lines resp. curves)
+
+ ------------------------------------------------------------------------------------------
+ Implementation notes:
+
+ This class combines the old Polygon and Curve classes.
+
+ The 1-bit fillForm to make display and containment tests reasonably fast. However, this functionality is in the process of being supplanted by balloon capabilities, which should eventually provide anti-aliasing as well.
+
+ wiz 7/18/2004 21:26
+ s have made some changes to this class to
+
+ 1) correct some bugs associated with one vertex polygons.
+
+ 2) prepare for some enhancements with new curves.
+
+ 3) add shaping items to menu.!
Item was added:
+ ----- Method: PolygonMorph class>>arrowPrototype (in category 'instance creation') -----
+ arrowPrototype
+ "Answer an instance of the receiver that will serve as a prototypical arrow"
+
+ | aa |
+ aa := self new.
+ aa vertices: (Array with: 0 at 0 with: 40 at 40)
+ color: Color black
+ borderWidth: 2
+ borderColor: Color black.
+ "aa setProperty: #noNewVertices toValue: true."
+ "Revert to expected behavior. Remove vestigial code."
+ aa makeForwardArrow. "is already open"
+ aa computeBounds.
+ ^ aa!
Item was added:
+ ----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Polygon'
+ categories: #('Graphics' 'Basic')
+ documentation: 'A series of connected line segments, which may be a closed solid, or a zig-zag line. Shift-click to get handles and move the points.'!
Item was added:
+ ----- Method: PolygonMorph class>>fromHand: (in category 'instance creation') -----
+ fromHand: hand
+ "Let the user draw a polygon, clicking at each vertex, and ending
+ by clicking within 5 of the first point..."
+ | p1 poly oldVerts pN opposite |
+ Cursor crossHair showWhile:
+ [[Sensor anyButtonPressed] whileFalse:
+ [self currentWorld displayWorldSafely; runStepMethods].
+ p1 := Sensor cursorPoint].
+ opposite := (Display colorAt: p1) negated.
+ opposite = Color transparent ifTrue: [opposite := Color red].
+ (poly := LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld.
+ oldVerts := {p1}.
+ self currentWorld displayWorldSafely; runStepMethods.
+
+ [[Sensor anyButtonPressed] whileTrue:
+ [pN := Sensor cursorPoint.
+ poly setVertices: (oldVerts copyWith: pN).
+ self currentWorld displayWorldSafely; runStepMethods].
+ (oldVerts size > 1 and: [(pN dist: p1) < 5]) ifTrue:
+ [hand position: Sensor cursorPoint. "Done -- update hand pos"
+ ^ (poly setVertices: (poly vertices copyWith: p1)) delete].
+ oldVerts := poly vertices.
+ [Sensor anyButtonPressed] whileFalse:
+ [pN := Sensor cursorPoint.
+ poly setVertices: (oldVerts copyWith: pN).
+ self currentWorld displayWorldSafely; runStepMethods]] repeat!
Item was added:
+ ----- Method: PolygonMorph class>>fromHandFreehand: (in category 'instance creation') -----
+ fromHandFreehand: hand
+ "Let the user draw a polygon, holding the mouse down, and ending
+ by clicking within 5 of the first point..."
+ | p1 poly pN opposite |
+ Cursor crossHair showWhile:
+ [[Sensor anyButtonPressed] whileFalse:
+ [self currentWorld displayWorldSafely; runStepMethods].
+ p1 := Sensor cursorPoint].
+ opposite := (Display colorAt: p1) negated.
+ opposite = Color transparent ifTrue: [opposite := Color red].
+ (poly := LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld.
+ self currentWorld displayWorldSafely; runStepMethods.
+ [Sensor anyButtonPressed] whileTrue:
+ [pN := Sensor cursorPoint.
+ (pN dist: poly vertices last) > 3 ifTrue:
+ [poly setVertices: (poly vertices copyWith: pN).
+ self currentWorld displayWorldSafely; runStepMethods]].
+ hand position: Sensor cursorPoint. "Done -- update hand pos"
+ ^ (poly setVertices: (poly vertices copyWith: p1)) delete!
Item was added:
+ ----- Method: PolygonMorph class>>shapeFromPen:color:borderWidth:borderColor: (in category 'instance creation') -----
+ shapeFromPen: penBlock color: c borderWidth: bw borderColor: bc
+ "World addMorph: (PolygonMorph
+ shapeFromPen: [:p | p hilbert: 4 side: 5. p go: 5.
+ p hilbert: 4 side: 5. p go: 5]
+ color: Color red borderWidth: 1 borderColor: Color black)"
+
+ | pen |
+ penBlock value: (pen := PenPointRecorder new).
+ ^ (self vertices: pen points asArray color: c borderWidth: bw borderColor: bc)
+ quickFill: false!
Item was added:
+ ----- Method: PolygonMorph class>>vertices:color:borderWidth:borderColor: (in category 'instance creation') -----
+ vertices: verts color: c borderWidth: bw borderColor: bc
+ ^ self basicNew beStraightSegments vertices: verts color: c borderWidth: bw borderColor: bc!
Item was added:
+ ----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu hand: aHandMorph
+ | |
+ super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu
+ addUpdating: #handlesShowingPhrase
+ target: self
+ action: #showOrHideHandles.
+ vertices size > 2
+ ifTrue: [ self addPolyLIneCurveMenuItems: aMenu hand: aHandMorph ].
+ aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
+ "aMenu add: 'use debug border' translated action: #showSegmentsBorderStyle."
+ self isOpen
+ ifTrue: [self addPolyArrowMenuItems: aMenu hand: aHandMorph]
+ ifFalse: [self addPolyShapingMenuItems: aMenu hand: aHandMorph]!
Item was added:
+ ----- Method: PolygonMorph>>addFlexShellIfNecessary (in category 'rotate scale and flex') -----
+ addFlexShellIfNecessary
+ "When scaling or rotating from a halo, I can do this without a flex shell"
+
+ ^ self
+ !
Item was added:
+ ----- Method: PolygonMorph>>addHandles (in category 'editing') -----
+ addHandles
+ "Put moving handles at the vertices. Put adding handles at
+ edge midpoints.
+ Moving over adjacent vertex and dropping will delete a
+ vertex. "
+ | tri |
+ self removeHandles.
+ handles := OrderedCollection new.
+ tri := Array
+ with: 0 @ -4
+ with: 4 @ 3
+ with: -3 @ 3.
+ vertices
+ withIndexDo: [:vertPt :vertIndex |
+ | handle |
+ handle := EllipseMorph
+ newBounds: (Rectangle center: vertPt extent: 8 @ 8)
+ color: (self handleColorAt: vertIndex) .
+ handle
+ on: #mouseMove
+ send: #dragVertex:event:fromHandle:
+ to: self
+ withValue: vertIndex.
+ handle
+ on: #mouseUp
+ send: #dropVertex:event:fromHandle:
+ to: self
+ withValue: vertIndex.
+ handle
+ on: #click
+ send: #clickVertex:event:fromHandle:
+ to: self
+ withValue: vertIndex.
+ self addMorph: handle.
+ handles addLast: handle.
+ (closed
+ or: [1 = vertices size
+ "Give a small polygon a chance to grow.
+ -wiz"
+ or: [vertIndex < vertices size]])
+ ifTrue: [| newVert |
+ newVert := PolygonMorph
+ vertices: (tri
+ collect: [:p | p + (vertPt
+ + (vertices atWrap: vertIndex + 1) // 2)])
+ color: Color green
+ borderWidth: 1
+ borderColor: Color black.
+ newVert
+ on: #mouseDown
+ send: #newVertex:event:fromHandle:
+ to: self
+ withValue: vertIndex.
+ self addMorph: newVert.
+ handles addLast: newVert]].
+ self isCurvy
+ ifTrue: [self updateHandles; layoutChanged].
+ self changed!
Item was added:
+ ----- Method: PolygonMorph>>addPolyArrowMenuItems:hand: (in category 'menu') -----
+ addPolyArrowMenuItems: aMenu hand: aHandMorph
+ aMenu addLine.
+ aMenu
+ addWithLabel: '---'
+ enablement: [self isOpen
+ and: [arrows ~~ #none]]
+ action: #makeNoArrows.
+ aMenu
+ addWithLabel: '-->'
+ enablement: [self isOpen
+ and: [arrows ~~ #forward]]
+ action: #makeForwardArrow.
+ aMenu
+ addWithLabel: '<--'
+ enablement: [self isOpen
+ and: [arrows ~~ #back]]
+ action: #makeBackArrow.
+ aMenu
+ addWithLabel: '<->'
+ enablement: [self isOpen
+ and: [arrows ~~ #both]]
+ action: #makeBothArrows.
+ aMenu add: 'customize arrows' translated action: #customizeArrows:.
+ (self hasProperty: #arrowSpec)
+ ifTrue: [aMenu add: 'standard arrows' translated action: #standardArrows]!
Item was added:
+ ----- Method: PolygonMorph>>addPolyLIneCurveMenuItems:hand: (in category 'menu') -----
+ addPolyLIneCurveMenuItems: aMenu hand: aHandMorph
+
+ aMenu addLine;
+ addUpdating: #openOrClosePhrase
+ target: self
+ action: #makeOpenOrClosed.
+
+ aMenu
+ addUpdating: #smoothOrSegmentedPhrase
+ target: self
+ action: #toggleSmoothing.!
Item was added:
+ ----- Method: PolygonMorph>>addPolyShapingMenuItems:hand: (in category 'menu') -----
+ addPolyShapingMenuItems: aMenu hand: aHandMorph
+ aMenu addLine.
+ aMenu
+ addWithLabel: 'make inscribed diamondOval'
+ enablement: [self isClosed ]
+ action: #diamondOval.
+ aMenu
+ addWithLabel: 'make enclosing rectangleOval'
+ enablement: [self isClosed ]
+ action: #rectOval.
+ !
Item was added:
+ ----- Method: PolygonMorph>>areasRemainingToFill: (in category 'drawing') -----
+ areasRemainingToFill: aRectangle
+ "Could be improved by quick check of inner rectangle"
+
+ ^ Array with: aRectangle!
Item was added:
+ ----- Method: PolygonMorph>>arrowBoundsAt:from: (in category 'private') -----
+ arrowBoundsAt: endPoint from: priorPoint
+ "Answer a triangle oriented along the line from priorPoint to endPoint."
+ | d v angle wingBase arrowSpec length width |
+ v := endPoint - priorPoint.
+ angle := v degrees.
+ d := borderWidth max: 1.
+ arrowSpec := self valueOfProperty: #arrowSpec ifAbsent: [5 at 4].
+ length := arrowSpec x abs. width := arrowSpec y abs.
+ wingBase := endPoint + (Point r: d * length degrees: angle + 180.0).
+ arrowSpec x >= 0
+ ifTrue: [^ { endPoint.
+ wingBase + (Point r: d * width degrees: angle + 125.0).
+ wingBase + (Point r: d * width degrees: angle - 125.0) }]
+ ifFalse: ["Negative length means concave base."
+ ^ { endPoint.
+ wingBase + (Point r: d * width degrees: angle + 125.0).
+ wingBase.
+ wingBase + (Point r: d * width degrees: angle - 125.0) }]!
Item was added:
+ ----- Method: PolygonMorph>>arrowForms (in category 'private') -----
+ arrowForms
+ "ArrowForms are computed only upon demand"
+ arrowForms
+ ifNotNil: [^ arrowForms].
+ arrowForms := Array new.
+ self hasArrows
+ ifFalse: [^ arrowForms].
+ (arrows == #forward
+ or: [arrows == #both])
+ ifTrue: [arrowForms := arrowForms
+ copyWith: (self computeArrowFormAt: vertices last from: self nextToLastPoint)].
+ (arrows == #back
+ or: [arrows == #both])
+ ifTrue: [arrowForms := arrowForms
+ copyWith: (self computeArrowFormAt: vertices first from: self nextToFirstPoint)].
+ ^ arrowForms!
Item was added:
+ ----- Method: PolygonMorph>>arrowLength: (in category 'menu') -----
+ arrowLength: aLength
+ "Assumes that I have exactly two vertices"
+
+ | theta horizontalOffset verticalOffset newTip delta |
+ delta := vertices second - vertices first.
+ theta := delta theta.
+ horizontalOffset := aLength * (theta cos).
+ verticalOffset := aLength * (theta sin).
+ newTip := vertices first + (horizontalOffset @ verticalOffset).
+ self verticesAt: 2 put: newTip!
Item was added:
+ ----- Method: PolygonMorph>>arrowSpec: (in category 'menu') -----
+ arrowSpec: specPt
+ "Specify a custom arrow for this line.
+ specPt x abs gives the length of the arrow (point to base) in terms of borderWidth.
+ If specPt x is negative, then the base of the arrow will be concave.
+ specPt y abs gives the width of the arrow.
+ The standard arrow is equivalent to arrowSpec: 5 at 4.
+ See arrowBoundsAt:From: for details."
+
+ self setProperty: #arrowSpec toValue: specPt.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>arrows (in category 'menu') -----
+ arrows
+ ^arrows!
Item was added:
+ ----- Method: PolygonMorph>>arrowsContainPoint: (in category 'geometry') -----
+ arrowsContainPoint: aPoint
+ "Answer an Array of two Booleans that indicate whether the given point is inside either arrow"
+
+ | retval f |
+
+ retval := { false . false }.
+ (super containsPoint: aPoint) ifFalse: [^ retval ].
+ (closed or: [arrows == #none or: [vertices size < 2]]) ifTrue: [^ retval].
+
+ (arrows == #forward or: [arrows == #both]) ifTrue: [ "arrowForms first has end form"
+ f := self arrowForms first.
+ retval at: 2 put: ((f pixelValueAt: aPoint - f offset) > 0)
+ ].
+ (arrows == #back or: [arrows == #both]) ifTrue: [ "arrowForms last has start form"
+ f := self arrowForms last.
+ retval at: 1 put: ((f pixelValueAt: aPoint - f offset) > 0)
+ ].
+ ^retval.!
Item was added:
+ ----- Method: PolygonMorph>>beSmoothCurve (in category 'initialization') -----
+ beSmoothCurve
+
+ smoothCurve == true ifFalse:
+ [smoothCurve := true.
+ self computeBounds]!
Item was added:
+ ----- Method: PolygonMorph>>beStraightSegments (in category 'initialization') -----
+ beStraightSegments
+
+ smoothCurve == false ifFalse:
+ [smoothCurve := false.
+ self computeBounds]!
Item was added:
+ ----- Method: PolygonMorph>>borderColor: (in category 'access') -----
+ borderColor: aColor
+
+ super borderColor: aColor.
+ (borderColor isColor and: [borderColor isTranslucentColor])
+ == (aColor isColor and: [aColor isTranslucentColor])
+ ifFalse:
+ ["Need to recompute fillForm and borderForm
+ if translucency of border changes."
+
+ self releaseCachedState]!
Item was added:
+ ----- Method: PolygonMorph>>borderDashOffset (in category 'dashes') -----
+ borderDashOffset
+ borderDashSpec size < 4 ifTrue: [^0.0].
+ ^(borderDashSpec fourth) asFloat!
Item was added:
+ ----- Method: PolygonMorph>>borderForm (in category 'private') -----
+ borderForm
+ "A form must be created for drawing the border whenever the borderColor is translucent."
+
+ | borderCanvas |
+ borderForm ifNotNil: [^ borderForm].
+ borderCanvas := (Display defaultCanvasClass extent: bounds extent depth: 1)
+ shadowColor: Color black.
+ borderCanvas translateBy: bounds topLeft negated
+ during:[:tempCanvas| self drawBorderOn: tempCanvas].
+ borderForm := borderCanvas form.
+ self arrowForms do:
+ [:f | "Eliminate overlap between line and arrowheads if transparent."
+ borderForm copy: f boundingBox from: f to: f offset - self position rule: Form erase].
+ ^ borderForm!
Item was added:
+ ----- Method: PolygonMorph>>borderWidth: (in category 'accessing') -----
+ borderWidth: anInteger
+
+ borderColor ifNil: [borderColor := Color black].
+ borderWidth := anInteger max: 0.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>bounds: (in category 'geometry') -----
+ bounds: newBounds
+ "This method has to be reimplemented since self extent: will also change self bounds origin,
+ super bounds would leave me in wrong position when container is growing.
+ Always change extent first then position"
+
+ self extent: newBounds extent; position: newBounds topLeft
+ !
Item was added:
+ ----- Method: PolygonMorph>>boundsSignatureHash (in category 'attachments') -----
+ boundsSignatureHash
+ ^(vertices - (self positionInWorld)) hash
+ !
Item was added:
+ ----- Method: PolygonMorph>>canHaveFillStyles (in category 'visual properties') -----
+ canHaveFillStyles
+ "Return true if the receiver can have general fill styles; not just colors.
+ This method is for gradually converting old morphs."
+ ^true!
Item was added:
+ ----- Method: PolygonMorph>>clickVertex:event:fromHandle: (in category 'editing') -----
+ clickVertex: ix event: evt fromHandle: handle
+ "Backstop for MixedCurveMorph"!
Item was added:
+ ----- Method: PolygonMorph>>closestPointTo: (in category 'geometry') -----
+ closestPointTo: aPoint
+ | closestPoint minDist |
+ closestPoint := minDist := nil.
+ self lineSegmentsDo:
+ [:p1 :p2 | | dist curvePoint |
+ curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2.
+ dist := curvePoint dist: aPoint.
+ (closestPoint isNil or: [dist < minDist])
+ ifTrue:
+ [closestPoint := curvePoint.
+ minDist := dist]].
+ ^closestPoint!
Item was added:
+ ----- Method: PolygonMorph>>closestSegmentTo: (in category 'geometry') -----
+ closestSegmentTo: aPoint
+ "Answer the starting index of my (big) segment nearest to aPoint"
+ | closestPoint minDist vertexIndex closestVertexIndex |
+ vertexIndex := 0.
+ closestVertexIndex := 0.
+ closestPoint := minDist := nil.
+ self lineSegmentsDo:
+ [:p1 :p2 | | dist curvePoint |
+ (p1 = (self vertices at: vertexIndex + 1))
+ ifTrue: [ vertexIndex := vertexIndex + 1 ].
+ curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2.
+ dist := curvePoint dist: aPoint.
+ (closestPoint == nil or: [dist < minDist])
+ ifTrue: [closestPoint := curvePoint.
+ minDist := dist.
+ closestVertexIndex := vertexIndex. ]].
+ ^ closestVertexIndex!
Item was added:
+ ----- Method: PolygonMorph>>coefficients (in category 'smoothing') -----
+ coefficients
+ "Compute an array for the coefficients."
+ | verts vertXs vertYs slopeXs slopeYs coefficients |
+ curveState
+ ifNotNil: [^ curveState at: 1].
+ verts := self vertices.
+ verts size < 1
+ ifTrue: [^ self].
+ "Less than three points handled as segments by our
+ lineSegmentsDo:"
+ (self isCurvier)
+ ifFalse: [closed
+ ifTrue: [verts := verts , verts first asOrderedCollection]].
+ coefficients := {
+ vertXs := verts collect: [:p | p x asFloat].
+ slopeXs := self slopes: vertXs.
+ vertXs changeInSlopes: slopeXs.
+ vertXs changeOfChangesInSlopes: slopeXs.
+ vertYs := verts collect: [:p | p y asFloat].
+ slopeYs := self slopes: vertYs.
+ vertYs changeInSlopes: slopeYs.
+ vertYs changeOfChangesInSlopes: slopeYs.
+ Array new: verts size withAll: 12}.
+ coefficients
+ at: 9
+ put: ((1 to: verts size)
+ collect: [:i | (coefficients cubicPointPolynomialAt: i) bestSegments]).
+ (self isCurvier)
+ ifFalse: [closed
+ ifTrue: [coefficients := coefficients
+ collect: [:each | each allButLast]]].
+ curveState := {coefficients. nil. nil}.
+ self computeNextToEndPoints.
+ ^ coefficients!
Item was added:
+ ----- Method: PolygonMorph>>computeArrowFormAt:from: (in category 'private') -----
+ computeArrowFormAt: endPoint from: priorPoint
+ "Compute a triangle oriented along the line from priorPoint to
+ endPoint. Then draw those lines in a form and return that
+ form, with appropriate offset"
+
+ | p1 pts box arrowForm bb origin |
+ pts := self arrowBoundsAt: endPoint from: priorPoint.
+ box := ((pts first rect: pts last) encompass: (pts second)) expandBy: 1.
+ arrowForm := Form extent: box extent asIntegerPoint.
+ bb := (BitBlt toForm: arrowForm)
+ sourceForm: nil;
+ fillColor: Color black;
+ combinationRule: Form over;
+ width: 1;
+ height: 1.
+ origin := box topLeft.
+ p1 := pts last - origin.
+ pts do:
+ [:p |
+ bb drawFrom: p1 to: p - origin.
+ p1 := p - origin].
+ arrowForm convexShapeFill: Color black.
+ ^arrowForm offset: box topLeft!
Item was added:
+ ----- Method: PolygonMorph>>computeBounds (in category 'private') -----
+ computeBounds
+ | oldBounds delta excludeHandles |
+ vertices ifNil: [^ self].
+
+ self changed.
+ oldBounds := bounds.
+ self releaseCachedState.
+ bounds := self curveBounds expanded copy.
+ self arrowForms do:
+ [:f | bounds swallow: (f offset extent: f extent)].
+ handles ifNotNil: [self updateHandles].
+
+ "since we are directly updating bounds, see if any ordinary submorphs exist and move them accordingly"
+ (oldBounds notNil and: [(delta := bounds origin - oldBounds origin) ~= (0 at 0)]) ifTrue: [
+ excludeHandles := IdentitySet new.
+ handles ifNotNil: [excludeHandles addAll: handles].
+ self submorphsDo: [ :each |
+ (excludeHandles includes: each) ifFalse: [
+ each position: each position + delta
+ ].
+ ].
+ ].
+ self layoutChanged.
+ self changed.
+ !
Item was added:
+ ----- Method: PolygonMorph>>computeNextToEndPoints (in category 'smoothing') -----
+ computeNextToEndPoints
+ | pointAfterFirst pointBeforeLast |
+ pointAfterFirst := nil.
+ self lineSegmentsDo:
+ [:p1 :p2 |
+ pointAfterFirst ifNil: [pointAfterFirst := p2 asIntegerPoint].
+ pointBeforeLast := p1 asIntegerPoint].
+ curveState at: 2 put: pointAfterFirst.
+ curveState at: 3 put: pointBeforeLast!
Item was added:
+ ----- Method: PolygonMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+ (super containsPoint: aPoint) ifFalse: [^ false].
+
+ closed & color isTransparent not ifTrue:
+ [^ (self filledForm pixelValueAt: aPoint - bounds topLeft + 1) > 0].
+
+ self lineSegmentsDo:
+ [:p1 :p2 |
+ (aPoint onLineFrom: p1 to: p2 within: (3 max: borderWidth+1//2) asFloat)
+ ifTrue: [^ true]].
+
+ self arrowForms do:
+ [:f | (f pixelValueAt: aPoint - f offset) > 0 ifTrue: [^ true]].
+
+ ^ false!
Item was added:
+ ----- Method: PolygonMorph>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ smoothCurve ifNil: [smoothCurve := false].
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: PolygonMorph>>cornerStyle: (in category 'rounding') -----
+ cornerStyle: aSymbol
+ "Set the receiver's corner style. But, in this case, do *not*"
+
+ self removeProperty: #cornerStyle.
+ self changed!
Item was added:
+ ----- Method: PolygonMorph>>couldHaveRoundedCorners (in category 'accessing') -----
+ couldHaveRoundedCorners
+ ^ false!
Item was added:
+ ----- Method: PolygonMorph>>curveBounds (in category 'private') -----
+ curveBounds
+ "Compute the bounds from actual curve traversal, with
+ leeway for borderWidth.
+ Also note the next-to-first and next-to-last points for arrow
+ directions."
+ "wiz - to avoid roundoff errors we return unrounded curvebounds."
+ "we expect our receiver to take responsibility for approriate rounding adjustment."
+ "hint: this is most likely 'self curveBounds expanded' "
+ | pointAfterFirst pointBeforeLast oX oY cX cY |
+ self isCurvy
+ ifFalse: [^ (Rectangle encompassing: vertices)
+ expandBy: borderWidth * 0.5 ].
+ curveState := nil.
+ "Force recomputation"
+ "curveBounds := vertices first corner: vertices last."
+ pointAfterFirst := nil.
+ self
+ lineSegmentsDo: [:p1 :p2 |
+ pointAfterFirst isNil
+ ifTrue: [pointAfterFirst := p2 floor .
+ oX := cX := p1 x.
+ oY := cY := p1 y. ].
+ "curveBounds := curveBounds encompass: p2 ."
+ oX:= oX min: p2 x.
+ cX := cX max: p2 x.
+ oY := oY min: p2 y.
+ cY := cY max: p2 y.
+ pointBeforeLast := p1 floor ].
+ curveState at: 2 put: pointAfterFirst.
+ curveState at: 3 put: pointBeforeLast.
+ ^ ( oX @ oY corner: cX @ cY ) expandBy: borderWidth * 0.5 !
Item was added:
+ ----- Method: PolygonMorph>>customizeArrows: (in category 'menu') -----
+ customizeArrows: evt
+ | handle origin aHand |
+ aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand].
+ origin := aHand position.
+ (handle := HandleMorph new)
+ forEachPointDo:
+ [:newPoint | handle removeAllMorphs.
+ handle addMorph:
+ (LineMorph from: origin to: newPoint color: Color black width: 1).
+ self arrowSpec: (newPoint - origin) / 5.0]
+ lastPointDo:
+ [:newPoint | handle deleteBalloon.
+ self halo ifNotNil: [:halo | halo addHandles].].
+ aHand attachMorph: handle.
+ handle setProperty: #helpAtCenter toValue: true.
+ handle showBalloon:
+ 'Move cursor left and right
+ to change arrow length and style.
+ Move it up and down to change width.
+ Click when done.' hand: evt hand.
+ handle startStepping!
Item was added:
+ ----- Method: PolygonMorph>>dashedBorder (in category 'dashes') -----
+ dashedBorder
+ ^borderDashSpec
+ "A dash spec is a 3- or 5-element array with
+ { length of normal border color.
+ length of alternate border color.
+ alternate border color.
+ starting offset.
+ amount to add to offset at each step }
+ Starting offset is usually = 0, but changing it moves the dashes along the curve."
+ !
Item was added:
+ ----- Method: PolygonMorph>>dashedBorder: (in category 'dashes') -----
+ dashedBorder: dashSpec
+ "A dash spec is a 3- or 5-element array with
+ { length of normal border color.
+ length of alternate border color.
+ alternate border color.
+ starting offset.
+ amount to add to offset at each step }
+ Starting offset is usually = 0, but changing it moves the dashes along the curve."
+
+ borderDashSpec := dashSpec.
+ self changed!
Item was added:
+ ----- Method: PolygonMorph>>defaultAttachmentPointSpecs (in category 'attachments') -----
+ defaultAttachmentPointSpecs
+ ^{
+ { #firstVertex } .
+ { #midpoint } .
+ { #lastVertex }
+ }!
Item was added:
+ ----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ Color
+ r: 0.0
+ g: 0.419
+ b: 0.935!
Item was added:
+ ----- Method: PolygonMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color orange!
Item was added:
+ ----- Method: PolygonMorph>>deleteVertexAt: (in category 'editing') -----
+ deleteVertexAt: anIndex
+ "This acts as a backstop for MixedCurveMorph."
+ self
+ setVertices: (vertices
+ copyReplaceFrom: anIndex
+ to: anIndex
+ with: Array new).
+ !
Item was added:
+ ----- Method: PolygonMorph>>derivs:first:second:third: (in category 'smoothing') -----
+ derivs: a first: point1 second: point2 third: point3
+ "Compute the first, second and third derivitives (in coeffs) from
+ the Points in this Path (coeffs at: 1 and coeffs at: 5)."
+
+ | len v anArray |
+ len := a size.
+ len < 2 ifTrue: [^self].
+ len > 2
+ ifTrue:
+ [v := Array new: len.
+ v at: 1 put: 4.0.
+ anArray := Array new: len.
+ anArray at: 1 put: 6.0 * (a first - (a second * 2.0) + (a third)).
+ 2 to: len - 2
+ do:
+ [:i |
+ v at: i put: 4.0 - (1.0 / (v at: i - 1)).
+ anArray at: i
+ put: 6.0 * ((a at: i) - ((a at: i + 1) * 2.0) + (a at: i + 2))
+ - ((anArray at: i - 1) / (v at: i - 1))].
+ point2 at: len - 1 put: (anArray at: len - 2) / (v at: len - 2).
+ len - 2 to: 2
+ by: 0 - 1
+ do:
+ [:i |
+ point2 at: i
+ put: ((anArray at: i - 1) - (point2 at: i + 1)) / (v at: i - 1)]].
+ point2 at: 1 put: (point2 at: len put: 0.0).
+ 1 to: len - 1
+ do:
+ [:i |
+ point1 at: i
+ put: (a at: i + 1) - (a at: i)
+ - (((point2 at: i) * 2.0 + (point2 at: i + 1)) / 6.0).
+ point3 at: i put: (point2 at: i + 1) - (point2 at: i)]!
Item was added:
+ ----- Method: PolygonMorph>>diamondOval (in category 'shaping') -----
+ diamondOval
+ "Set my vertices to an array of edge midpoint vertices.
+ Order of vertices is in the tradion of warpblt quads."
+ | b r |
+ b := self bounds.
+ r := {b leftCenter. b bottomCenter. b rightCenter. b topCenter}.
+ self setVertices: r!
Item was added:
+ ----- Method: PolygonMorph>>dragVertex:event:fromHandle: (in category 'editing') -----
+ dragVertex: ix event: evt fromHandle: handle
+ | p |
+ p := self isCurve
+ ifTrue: [evt cursorPoint]
+ ifFalse: [self griddedPoint: evt cursorPoint].
+ handle position: p - (handle extent//2).
+ self verticesAt: ix put: p.
+ !
Item was added:
+ ----- Method: PolygonMorph>>dragVertex:fromHandle:vertIndex: (in category 'editing') -----
+ dragVertex: arg1 fromHandle: arg2 vertIndex: arg3
+ "Reorder the arguments for existing event handlers"
+ (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
+ ^self dragVertex: arg1 event: arg2 fromHandle: arg3!
Item was added:
+ ----- Method: PolygonMorph>>drawArrowOn:at:from: (in category 'drawing') -----
+ drawArrowOn: aCanvas at: endPoint from: priorPoint
+ "Draw a triangle oriented along the line from priorPoint to
+ endPoint. Answer the wingBase."
+
+ | pts spec wingBase |
+ pts := self arrowBoundsAt: endPoint from: priorPoint.
+ wingBase := pts size = 4
+ ifTrue: [pts third]
+ ifFalse: [(pts copyFrom: 2 to: 3) average].
+ spec := self valueOfProperty: #arrowSpec ifAbsent: [5 @ 4].
+ spec x sign = spec y sign
+ ifTrue: [aCanvas drawPolygon: pts fillStyle: borderColor]
+ ifFalse:
+ [aCanvas
+ drawPolygon: pts
+ fillStyle: Color transparent
+ borderWidth: (borderWidth + 1) // 2
+ borderColor: borderColor].
+ ^wingBase!
Item was added:
+ ----- Method: PolygonMorph>>drawArrowsOn: (in category 'drawing') -----
+ drawArrowsOn: aCanvas
+ "Answer (possibly modified) endpoints for border drawing"
+ "ArrowForms are computed only upon demand"
+ | array |
+
+ self hasArrows
+ ifFalse: [^ #() ].
+ "Nothing to do"
+
+ array := Array with: vertices first with: vertices last.
+
+ "Prevent crashes for #raised or #inset borders"
+ borderColor isColor
+ ifFalse: [ ^array ].
+
+ (arrows == #forward or: [arrows == #both])
+ ifTrue: [ array at: 2 put: (self
+ drawArrowOn: aCanvas
+ at: vertices last
+ from: self nextToLastPoint) ].
+
+ (arrows == #back or: [arrows == #both])
+ ifTrue: [ array at: 1 put: (self
+ drawArrowOn: aCanvas
+ at: vertices first
+ from: self nextToFirstPoint) ].
+
+ ^array!
Item was added:
+ ----- Method: PolygonMorph>>drawBorderOn: (in category 'drawing') -----
+ drawBorderOn: aCanvas
+ self
+ drawClippedBorderOn: aCanvas
+ usingEnds: (Array with: vertices first with: vertices last)!
Item was added:
+ ----- Method: PolygonMorph>>drawBorderOn:usingEnds: (in category 'drawing') -----
+ drawBorderOn: aCanvas usingEnds: anArray
+ "Display my border on the canvas."
+ "NOTE: Much of this code is also copied in
+ drawDashedBorderOn:
+ (should be factored)"
+ | bigClipRect style |
+ borderDashSpec
+ ifNotNil: [^ self drawDashedBorderOn: aCanvas usingEnds: anArray].
+ style := self borderStyle.
+ bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2.
+ self
+ lineSegmentsDo: [:p1 :p2 | | p2i p1i |
+ p1i := p1 asIntegerPoint.
+ p2i := p2 asIntegerPoint.
+ self hasArrows
+ ifTrue: ["Shorten line ends so as not to interfere with tip
+ of arrow."
+ ((arrows == #back
+ or: [arrows == #both])
+ and: [p1 = vertices first])
+ ifTrue: [p1i := anArray first asIntegerPoint].
+ ((arrows == #forward
+ or: [arrows == #both])
+ and: [p2 = vertices last])
+ ifTrue: [p2i := anArray last asIntegerPoint]].
+ (closed
+ or: ["bigClipRect intersects: (p1i rect: p2i)
+ optimized:"
+ ((p1i min: p2i)
+ max: bigClipRect origin)
+ <= ((p1i max: p2i)
+ min: bigClipRect corner)])
+ ifTrue: [style
+ drawLineFrom: p1i
+ to: p2i
+ on: aCanvas]]!
Item was added:
+ ----- Method: PolygonMorph>>drawClippedBorderOn:usingEnds: (in category 'drawing') -----
+ drawClippedBorderOn: aCanvas usingEnds: anArray
+ aCanvas clipBy: self bounds during:[:cc| self drawBorderOn: cc usingEnds: anArray].!
Item was added:
+ ----- Method: PolygonMorph>>drawDashedBorderOn: (in category 'drawing') -----
+ drawDashedBorderOn: aCanvas
+ self
+ drawDashedBorderOn: aCanvas
+ usingEnds: (Array with: vertices first with: vertices last)!
Item was added:
+ ----- Method: PolygonMorph>>drawDashedBorderOn:usingEnds: (in category 'drawing') -----
+ drawDashedBorderOn: aCanvas usingEnds: anArray
+ "Display my border on the canvas. NOTE: mostly copied from
+ drawBorderOn:"
+ | bevel topLeftColor bottomRightColor bigClipRect lineColor segmentOffset |
+ (borderColor isNil
+ or: [borderColor isColor
+ and: [borderColor isTransparent]])
+ ifTrue: [^ self].
+ lineColor := borderColor.
+ bevel := false.
+ "Border colors for bevelled effects depend on CW ordering of
+ vertices"
+ borderColor == #raised
+ ifTrue: [topLeftColor := color lighter.
+ bottomRightColor := color darker.
+ bevel := true].
+ borderColor == #inset
+ ifTrue: [topLeftColor := owner colorForInsets darker.
+ bottomRightColor := owner colorForInsets lighter.
+ bevel := true].
+ bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2.
+ segmentOffset := self borderDashOffset.
+ self
+ lineSegmentsDo: [:p1 :p2 | | p1i p2i |
+ p1i := p1 asIntegerPoint.
+ p2i := p2 asIntegerPoint.
+ self hasArrows
+ ifTrue: ["Shorten line ends so as not to interfere with tip
+ of arrow."
+ ((arrows == #back
+ or: [arrows == #both])
+ and: [p1 = vertices first])
+ ifTrue: [p1i := anArray first asIntegerPoint].
+ ((arrows == #forward
+ or: [arrows == #both])
+ and: [p2 = vertices last])
+ ifTrue: [p2i := anArray last asIntegerPoint]].
+ (closed
+ or: ["bigClipRect intersects: (p1i rect: p2i)
+ optimized:"
+ ((p1i min: p2i)
+ max: bigClipRect origin)
+ <= ((p1i max: p2i)
+ min: bigClipRect corner)])
+ ifTrue: [bevel
+ ifTrue: [lineColor := (p1i quadrantOf: p2i)
+ > 2
+ ifTrue: [topLeftColor]
+ ifFalse: [bottomRightColor]].
+ segmentOffset := aCanvas
+ line: p1i
+ to: p2i
+ width: borderWidth
+ color: lineColor
+ dashLength: borderDashSpec first
+ secondColor: borderDashSpec third
+ secondDashLength: borderDashSpec second
+ startingOffset: segmentOffset]]!
Item was added:
+ ----- Method: PolygonMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Display the receiver, a spline curve, approximated by straight
+ line segments."
+ | array |
+ vertices size < 1
+ ifTrue: [self error: 'a polygon must have at least one point'].
+ closed ifTrue:
+ [aCanvas drawPolygon: self getVertices fillStyle: self fillStyle.
+ aCanvas isShadowDrawing ifTrue: [^ self]].
+ array := self drawArrowsOn: aCanvas.
+ self drawClippedBorderOn: aCanvas usingEnds: array.
+ !
Item was added:
+ ----- Method: PolygonMorph>>drawOnFormCanvas: (in category 'drawing') -----
+ drawOnFormCanvas: aCanvas
+ "Display the receiver, a spline curve, approximated by straight line segments."
+
+ | |
+ vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point'].
+ closed & color isTransparent not
+ ifTrue: [aCanvas stencil: self filledForm at: bounds topLeft - 1 color: color].
+ (borderColor isColor and: [borderColor isTranslucentColor])
+ ifTrue: [aCanvas stencil: self borderForm at: bounds topLeft
+ color: borderColor]
+ ifFalse: [self drawBorderOn: aCanvas].
+ self arrowForms do:
+ [:f | aCanvas stencil: f at: f offset
+ color: (borderColor isColor ifTrue: [borderColor] ifFalse: [color])]!
Item was added:
+ ----- Method: PolygonMorph>>dropVertex:event:fromHandle: (in category 'editing') -----
+ dropVertex: ix event: evt fromHandle: handle
+ "Leave vertex in new position. If dropped ontop another vertex delete this one.
+ Check for too few vertices before deleting. The alternative
+ is not pretty -wiz"
+ | p |
+ p := vertices at: ix.
+ (vertices size >= 2
+ and: ["check for too few vertices before deleting. The alternative
+ is not pretty -wiz"
+ ((vertices atWrap: ix - 1)
+ dist: p)
+ < 3
+ or: [((vertices atWrap: ix + 1)
+ dist: p)
+ < 3]])
+ ifTrue: ["Drag a vertex onto its neighbor means delete"
+ self deleteVertexAt: ix .].
+ evt shiftPressed
+ ifTrue: [self removeHandles]
+ ifFalse: [self addHandles
+ "remove then add to recreate"]!
Item was added:
+ ----- Method: PolygonMorph>>dropVertex:fromHandle:vertIndex: (in category 'editing') -----
+ dropVertex: arg1 fromHandle: arg2 vertIndex: arg3
+ "Reorder the arguments for existing event handlers"
+ (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
+ ^self dropVertex: arg1 event: arg2 fromHandle: arg3!
Item was added:
+ ----- Method: PolygonMorph>>endShapeColor: (in category 'attachments') -----
+ endShapeColor: aColor
+ self borderColor: aColor.
+ self isClosed ifTrue: [ self color: aColor ].!
Item was added:
+ ----- Method: PolygonMorph>>endShapeWidth: (in category 'attachments') -----
+ endShapeWidth: aWidth
+ | originalWidth originalVertices transform |
+ originalWidth := self valueOfProperty: #originalWidth ifAbsentPut: [ self borderWidth isZero ifFalse: [ self borderWidth ] ifTrue: [ 2 ] ].
+ self borderWidth: aWidth.
+ originalVertices := self valueOfProperty: #originalVertices ifAbsentPut: [
+ self vertices collect: [ :ea | (ea - (self referencePosition)) rotateBy: self heading degreesToRadians about: 0 at 0 ]
+ ].
+ transform := MorphicTransform offset: 0 at 0 angle: self heading degreesToRadians scale: originalWidth / aWidth.
+ self setVertices: (originalVertices collect: [ :ea |
+ ((transform transform: ea) + self referencePosition) asIntegerPoint
+ ]).
+ self computeBounds.!
Item was added:
+ ----- Method: PolygonMorph>>extent: (in category 'geometry') -----
+ extent: newExtent
+ "Not really advisable, but we can preserve most of the geometry if we don't
+ shrink things too small."
+ | safeExtent center |
+ center := self referencePosition.
+ safeExtent := newExtent max: 20 at 20.
+ self setVertices: (vertices collect:
+ [:p | p - center * (safeExtent asFloatPoint / (bounds extent max: 1 at 1)) + center])!
Item was added:
+ ----- Method: PolygonMorph>>fillStyle (in category 'visual properties') -----
+ fillStyle
+
+ self isOpen
+ ifTrue: [^ self borderColor "easy access to line color from halo"]
+ ifFalse: [^ super fillStyle]!
Item was added:
+ ----- Method: PolygonMorph>>fillStyle: (in category 'visual properties') -----
+ fillStyle: newColor
+
+ self isOpen
+ ifTrue: [^ self borderColor: newColor asColor "easy access to line color from halo"]
+ ifFalse: [^ super fillStyle: newColor]!
Item was added:
+ ----- Method: PolygonMorph>>filledForm (in category 'private') -----
+ filledForm
+ "Note: The filled form is actually 2 pixels bigger than bounds, and the point corresponding to this morphs' position is at 1 at 1 in the form. This is due to the details of the fillig routines, at least one of which requires an extra 1-pixel margin around the outside. Computation of the filled form is done only on demand."
+ | bb origin |
+ closed ifFalse: [^ filledForm := nil].
+ filledForm ifNotNil: [^ filledForm].
+ filledForm := Form extent: bounds extent+2.
+
+ "Draw the border..."
+ bb := (BitBlt toForm: filledForm) sourceForm: nil; fillColor: Color black;
+ combinationRule: Form over; width: 1; height: 1.
+ origin := bounds topLeft asIntegerPoint-1.
+ self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1 asIntegerPoint-origin
+ to: p2 asIntegerPoint-origin].
+
+ "Fill it in..."
+ filledForm convexShapeFill: Color black.
+
+ (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue:
+ ["If border is stored as a form, then erase any overlap now."
+ filledForm copy: self borderForm boundingBox from: self borderForm
+ to: 1 at 1 rule: Form erase].
+
+ ^ filledForm!
Item was added:
+ ----- Method: PolygonMorph>>firstVertex (in category 'attachments') -----
+ firstVertex
+ ^vertices first!
Item was added:
+ ----- Method: PolygonMorph>>flipHAroundX: (in category 'geometry') -----
+ flipHAroundX: centerX
+ "Flip me horizontally around the center. If centerX is nil, compute my center of gravity."
+
+ | cent |
+ cent := centerX
+ ifNil: [bounds center x
+ "cent := 0.
+ vertices do: [:each | cent := cent + each x].
+ cent asFloat / vertices size"] "average is the center"
+ ifNotNil: [centerX].
+ self setVertices: (vertices collect: [:vv |
+ ((vv x - cent) * -1 + cent) @ vv y]) reversed.!
Item was added:
+ ----- Method: PolygonMorph>>flipVAroundY: (in category 'geometry') -----
+ flipVAroundY: centerY
+ "Flip me vertically around the center. If centerY is nil, compute my center of gravity."
+
+ | cent |
+ cent := centerY
+ ifNil: [bounds center y
+ "cent := 0.
+ vertices do: [:each | cent := cent + each y].
+ cent asFloat / vertices size"] "average is the center"
+ ifNotNil: [centerY].
+ self setVertices: (vertices collect: [:vv |
+ vv x @ ((vv y - cent) * -1 + cent)]) reversed.!
Item was added:
+ ----- Method: PolygonMorph>>getVertices (in category 'private') -----
+ getVertices
+
+ smoothCurve ifFalse: [^ vertices].
+
+ "For curves, enumerate the full set of interpolated points"
+ ^ Array streamContents:
+ [:s | self lineSegmentsDo: [:pt1 :pt2 | s nextPut: pt1]]!
Item was added:
+ ----- Method: PolygonMorph>>handleColorAt: (in category 'editing') -----
+ handleColorAt: vertIndex
+ "This is a backstop for MixedCurveMorph"
+
+ ^ Color yellow
+ !
Item was added:
+ ----- Method: PolygonMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ (super handlesMouseDown: evt) or: [evt shiftPressed]!
Item was added:
+ ----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') -----
+ handlesShowingPhrase
+ ^ (self showingHandles
+ ifTrue: ['hide handles']
+ ifFalse: ['show handles']) translated!
Item was added:
+ ----- Method: PolygonMorph>>hasArrows (in category 'testing') -----
+ hasArrows
+ "Are all the conditions meet for having arrows?"
+ ^ (closed
+ or: [arrows == #none
+ or: [vertices size < 2]]) not!
Item was added:
+ ----- Method: PolygonMorph>>includesHandle: (in category 'private') -----
+ includesHandle: aMorph
+
+ handles ifNil: [^ false].
+ ^ handles includes: aMorph!
Item was added:
+ ----- Method: PolygonMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ vertices := Array
+ with: 5 @ 0
+ with: 20 @ 10
+ with: 0 @ 20.
+ closed := true.
+ smoothCurve := false.
+ arrows := #none.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>insertVertexAt:put: (in category 'editing') -----
+ insertVertexAt: anIndex put: aValue
+ "This serves as a hook and a backstop for MixedCurveMorph."
+ self setVertices: (vertices copyReplaceFrom: anIndex + 1 to: anIndex
+ with: (Array with: aValue)).!
Item was added:
+ ----- Method: PolygonMorph>>installModelIn: (in category 'debug and other') -----
+ installModelIn: aWorld
+ aWorld isWorldMorph ifTrue: [self addHandles]!
Item was added:
+ ----- Method: PolygonMorph>>intersectionWithLineSegmentFromCenterTo: (in category 'geometry') -----
+ intersectionWithLineSegmentFromCenterTo: aPoint
+ ^self closestPointTo: aPoint!
Item was added:
+ ----- Method: PolygonMorph>>intersectionsWith: (in category 'geometry') -----
+ intersectionsWith: aRectangle
+ "Answer a Set of points where the given Rectangle intersects with me.
+ Ignores arrowForms."
+
+ | retval |
+ retval := IdentitySet new: 4.
+ (self bounds intersects: aRectangle) ifFalse: [^ retval].
+
+ self lineSegmentsDo: [ :lp1 :lp2 | | polySeg |
+ polySeg := LineSegment from: lp1 to: lp2.
+ aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg int |
+ rectSeg := LineSegment from: rp1 to: rp2.
+ int := polySeg intersectionWith: rectSeg.
+ int ifNotNil: [ retval add: int ].
+ ].
+ ].
+
+ ^retval
+ !
Item was added:
+ ----- Method: PolygonMorph>>intersects: (in category 'geometry') -----
+ intersects: aRectangle
+ "Answer whether any of my segments intersects aRectangle, which is in World coordinates."
+ | rect |
+ (super intersects: aRectangle) ifFalse: [ ^false ].
+ rect := self bounds: aRectangle in: self world.
+ self
+ lineSegmentsDo: [:p1 :p2 | (rect intersectsLineFrom: p1 to: p2)
+ ifTrue: [^ true]].
+ ^ false!
Item was added:
+ ----- Method: PolygonMorph>>isBordered (in category 'geometry') -----
+ isBordered
+ ^false!
Item was added:
+ ----- Method: PolygonMorph>>isClosed (in category 'access') -----
+ isClosed
+ ^ closed!
Item was added:
+ ----- Method: PolygonMorph>>isCurve (in category 'access') -----
+ isCurve
+ ^ smoothCurve!
Item was added:
+ ----- Method: PolygonMorph>>isCurvier (in category 'testing') -----
+ isCurvier
+ "Test used by smoothing routines. If true use true closed curve splines for closed curves. If not mimic old stodgy curveMorph curves with one sharp bend.. Override this routine in classes where backward compatability is still needed."
+ ^ CurvierMorph drawCurvier!
Item was added:
+ ----- Method: PolygonMorph>>isCurvy (in category 'testing') -----
+ isCurvy
+ "Test for significant curves.
+ Small smoothcurves in practice are straight."
+ ^ smoothCurve
+ and: [vertices size > 2]!
Item was added:
+ ----- Method: PolygonMorph>>isLineMorph (in category 'testing') -----
+ isLineMorph
+ ^closed not!
Item was added:
+ ----- Method: PolygonMorph>>isOpen (in category 'access') -----
+ isOpen
+ ^ closed not!
Item was added:
+ ----- Method: PolygonMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: newOwner event: evt
+
+ | delta |
+ (newOwner isKindOf: PasteUpMorph) ifTrue:
+ ["Compensate for border width so that gridded drop
+ is consistent with gridded drag of handles."
+ delta := borderWidth+1//2.
+ self position: (newOwner gridPoint: self position + delta) - delta].
+ ^ super justDroppedInto: newOwner event: evt!
Item was added:
+ ----- Method: PolygonMorph>>lastVertex (in category 'attachments') -----
+ lastVertex
+ ^vertices last!
Item was added:
+ ----- Method: PolygonMorph>>lineBorderColor (in category 'geometry') -----
+ lineBorderColor
+ ^self borderColor!
Item was added:
+ ----- Method: PolygonMorph>>lineBorderColor: (in category 'geometry') -----
+ lineBorderColor: aColor
+ self borderColor: aColor!
Item was added:
+ ----- Method: PolygonMorph>>lineBorderWidth (in category 'geometry') -----
+ lineBorderWidth
+
+ ^self borderWidth!
Item was added:
+ ----- Method: PolygonMorph>>lineBorderWidth: (in category 'geometry') -----
+ lineBorderWidth: anInteger
+
+ self borderWidth: anInteger!
Item was added:
+ ----- Method: PolygonMorph>>lineColor (in category 'geometry') -----
+ lineColor
+ ^self borderColor!
Item was added:
+ ----- Method: PolygonMorph>>lineColor: (in category 'geometry') -----
+ lineColor: aColor
+ self borderColor: aColor!
Item was added:
+ ----- Method: PolygonMorph>>lineSegments (in category 'private') -----
+ lineSegments
+ | lineSegments |
+ lineSegments := OrderedCollection new.
+ self lineSegmentsDo: [:p1 :p2 | lineSegments addLast: (Array with: p1 with: p2)].
+ ^ lineSegments!
Item was added:
+ ----- Method: PolygonMorph>>lineSegmentsDo: (in category 'smoothing') -----
+ lineSegmentsDo: endPointsBlock
+ "Emit a sequence of segment endpoints into endPointsBlock."
+ "Unlike the method this one replaces we expect the curve
+ coefficents not the dirivatives"
+ "Also unlike the replaced method the smooth closed curve
+ does
+ not need an extra vertex.
+ We take care of the extra endpoint here. Just like for
+ segmented curves."
+ | cs x y beginPoint |
+ vertices size < 1
+ ifTrue: [^ self].
+ "test too few vertices first"
+ self isCurvy
+ ifFalse: [beginPoint := nil.
+ "smoothCurve
+ ifTrue: [cs := self coefficients]."
+ "some things still depend on smoothCurves having
+ curveState"
+ vertices
+ do: [:vert |
+ beginPoint
+ ifNotNil: [endPointsBlock value: beginPoint value: vert].
+ beginPoint := vert].
+ (closed
+ or: [vertices size = 1])
+ ifTrue: [endPointsBlock value: beginPoint value: vertices first].
+ ^ self].
+ "For curves we include all the interpolated sub segments."
+ "self assert: [(vertices size > 2 )]. "
+ cs := self coefficients.
+ beginPoint := (x := cs first first) @ (y := cs fifth first).
+ (closed
+ ifTrue: [1 to: cs first size]
+ ifFalse: [1 to: cs first size - 1])
+ do: [:i | | x1 y1 endPoint n y2 t x3 y3 x2 |
+ "taylor series coefficients"
+ x1 := cs second at: i.
+ y1 := cs sixth at: i.
+ x2 := cs third at: i.
+ y2 := cs seventh at: i.
+ x3 := cs fourth at: i.
+ y3 := cs eighth at: i.
+ n := cs ninth at: i.
+ "guess n
+ n := 5 max: (x2 abs + y2 abs * 2.0 + (cs third atWrap:
+ i
+ + 1) abs + (cs seventh atWrap: i + 1) abs / 100.0)
+ rounded."
+ 1
+ to: n - 1
+ do: [:j |
+ t := j asFloat / n asFloat.
+ endPoint := x3 * t + x2 * t + x1 * t + x @ (y3 * t + y2 * t + y1 * t + y).
+ endPointsBlock value: beginPoint value: endPoint.
+ beginPoint := endPoint].
+ endPoint := (x := cs first atWrap: i + 1) @ (y := cs fifth atWrap: i + 1).
+ endPointsBlock value: beginPoint value: endPoint.
+ beginPoint := endPoint]!
Item was added:
+ ----- Method: PolygonMorph>>lineWidth (in category 'geometry') -----
+ lineWidth
+
+ ^self borderWidth!
Item was added:
+ ----- Method: PolygonMorph>>lineWidth: (in category 'geometry') -----
+ lineWidth: anInteger
+
+ self borderWidth: (anInteger rounded max: 1)!
Item was added:
+ ----- Method: PolygonMorph>>loadCachedState (in category 'caching') -----
+ loadCachedState
+ "Prepare for fast response -- next page of a book?"
+ self filledForm.
+ self arrowForms!
Item was added:
+ ----- Method: PolygonMorph>>makeBackArrow (in category 'menu') -----
+ makeBackArrow
+ arrows := #back.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>makeBothArrows (in category 'menu') -----
+ makeBothArrows
+ arrows := #both.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>makeClosed (in category 'menu') -----
+ makeClosed
+ closed := true.
+ handles ifNotNil: [self removeHandles; addHandles].
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>makeForwardArrow (in category 'menu') -----
+ makeForwardArrow
+ arrows := #forward.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>makeNoArrows (in category 'menu') -----
+ makeNoArrows
+ arrows := #none.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>makeOpen (in category 'menu') -----
+ makeOpen
+ closed := false.
+ handles ifNotNil: [self removeHandles; addHandles].
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>makeOpenOrClosed (in category 'access') -----
+ makeOpenOrClosed
+ "toggle the open/closed status of the receiver"
+ closed ifTrue: [self makeOpen] ifFalse: [self makeClosed]!
Item was added:
+ ----- Method: PolygonMorph>>merge: (in category 'geometry') -----
+ merge: aPolygon
+ "Expand myself to enclose the other polygon. (Later merge overlapping or disjoint in a smart way.) For now, the two polygons must share at least two vertices. Shared vertices must come one after the other in each polygon. Polygons must not overlap."
+
+ | shared mv vv hv xx |
+ shared := vertices select: [:mine | aPolygon vertices includes: mine].
+ shared size < 2 ifTrue: [^nil]. "not sharing a segment"
+ mv := vertices asOrderedCollection.
+ [shared includes: mv first] whileFalse:
+ ["rotate them"
+
+ vv := mv removeFirst.
+ mv addLast: vv].
+ hv := aPolygon vertices asOrderedCollection.
+ [mv first = hv first] whileFalse:
+ ["rotate him until same shared vertex is first"
+
+ vv := hv removeFirst.
+ hv addLast: vv].
+ [shared size > 2] whileTrue:
+ [shared := shared asOrderedCollection.
+ (self
+ mergeDropThird: mv
+ in: hv
+ from: shared) ifNil: [^nil]].
+ "works by side effect on the lists"
+ (mv second) = hv last
+ ifTrue:
+ [mv
+ removeFirst;
+ removeFirst.
+ ^self setVertices: (hv , mv) asArray].
+ (hv second) = mv last
+ ifTrue:
+ [hv
+ removeFirst;
+ removeFirst.
+ ^self setVertices: (mv , hv) asArray].
+ (mv second) = (hv second)
+ ifTrue:
+ [hv removeFirst.
+ mv remove: (mv second).
+ xx := mv removeFirst.
+ ^self setVertices: (hv , (Array with: xx) , mv reversed) asArray].
+ mv last = hv last
+ ifTrue:
+ [mv removeLast.
+ hv removeFirst.
+ ^self setVertices: (mv , hv reversed) asArray].
+ ^nil!
Item was added:
+ ----- Method: PolygonMorph>>mergeDropThird:in:from: (in category 'geometry') -----
+ mergeDropThird: mv in: hv from: shared
+ "We are merging two polygons. In this case, they have at least three identical shared vertices. Make sure they are sequential in each, and drop the middle one from vertex lists mv, hv, and shared. First vertices on lists are identical already."
+
+ "know (mv first = hv first)"
+
+ | mdrop vv |
+ (shared includes: (mv at: mv size - 2))
+ ifTrue: [(shared includes: mv last) ifTrue: [mdrop := mv last]]
+ ifFalse:
+ [(shared includes: mv last)
+ ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv first]]].
+ (shared includes: (mv third))
+ ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv second]].
+ mdrop ifNil: [^nil].
+ mv remove: mdrop.
+ hv remove: mdrop.
+ shared remove: mdrop.
+ [shared includes: mv first] whileFalse:
+ ["rotate them"
+
+ vv := mv removeFirst.
+ mv addLast: vv].
+ [mv first = hv first] whileFalse:
+ ["rotate him until same shared vertex is first"
+
+ vv := hv removeFirst.
+ hv addLast: vv]!
Item was added:
+ ----- Method: PolygonMorph>>midVertices (in category 'access') -----
+ midVertices
+ "Return and array of midpoints for this line or closed curve"
+ | midPts nextVertIx tweens |
+ vertices size < 2
+ ifTrue: [^ vertices].
+ midPts := OrderedCollection new.
+ nextVertIx := 2.
+ tweens := OrderedCollection new.
+ tweens add: vertices first asIntegerPoint.
+ "guarantee at least two points."
+ self
+ lineSegmentsDo: [:p1 :p2 |
+ tweens addLast: p2 asIntegerPoint.
+ p2
+ = (vertices atWrap: nextVertIx)
+ ifTrue: ["Found endPoint."
+ midPts addLast: (tweens atWrap: tweens size + 1 // 2)
+ + (tweens at: tweens size // 2 + 1) // 2.
+ "wiz 6/19/2004 20:11 adjusted to handle
+ one segment properly"
+ tweens := OrderedCollection new.
+ tweens add: p2 asIntegerPoint.
+ "guarantee at least two points."
+ nextVertIx := nextVertIx + 1]].
+ ^ midPts asArray!
Item was added:
+ ----- Method: PolygonMorph>>midpoint (in category 'attachments') -----
+ midpoint
+ "Answer the midpoint along my segments"
+ | middle |
+ middle := self totalLength.
+ middle < 2 ifTrue: [ ^ self center ].
+ middle := middle / 2.
+ self lineSegmentsDo: [ :a :b | | dist |
+ dist := (a dist: b).
+ middle < dist
+ ifTrue: [ ^(a + ((b - a) * (middle / dist))) asIntegerPoint ].
+ middle := middle - dist.
+ ].
+ self error: 'can''t happen'!
Item was added:
+ ----- Method: PolygonMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+
+ ^ evt shiftPressed
+ ifTrue: [((owner isKindOf: PolygonMorph) and: [owner includesHandle: self])
+ ifTrue: ["Prevent insertion handles from getting edited"
+ ^ super mouseDown: evt].
+ self toggleHandles.
+ handles ifNil: [^ self].
+ vertices withIndexDo: "Check for click-to-drag at handle site"
+ [:vertPt :vertIndex |
+ ((handles at: vertIndex*2-1 ifAbsent: [ ^self ]) containsPoint: evt cursorPoint) ifTrue:
+ ["If clicked near a vertex, jump into drag-vertex action"
+ evt hand newMouseFocus: (handles at: vertIndex*2-1)]]]
+ ifFalse: [super mouseDown: evt]!
Item was added:
+ ----- Method: PolygonMorph>>newVertex:event:fromHandle: (in category 'editing') -----
+ newVertex: ix event: evt fromHandle: handle
+ "Insert a new vertex and fix everything up!! Install the drag-handle of the new vertex as recipient of further mouse events."
+
+ | pt |
+ "(self hasProperty: #noNewVertices) ifFalse:
+ [pt := evt cursorPoint.
+ self setVertices: (vertices copyReplaceFrom: ix + 1 to: ix with: (Array with: pt)).
+ evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1)]"
+ "modified to remove now vestigial test. see PolygonMorph class>>arrowprototype"
+ pt := evt cursorPoint.
+ self insertVertexAt: ix put: pt .
+ evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1)!
Item was added:
+ ----- Method: PolygonMorph>>newVertex:fromHandle:afterVert: (in category 'editing') -----
+ newVertex: arg1 fromHandle: arg2 afterVert: arg3
+ "Reorder the arguments for existing event handlers"
+ (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages].
+ ^self newVertex: arg1 event: arg2 fromHandle: arg3!
Item was added:
+ ----- Method: PolygonMorph>>nextDuplicateVertexIndex (in category 'geometry') -----
+ nextDuplicateVertexIndex
+ vertices
+ doWithIndex: [:vert :index | ((index between: 2 and: vertices size - 1)
+ and: [| epsilon v1 v2 |
+ v1 := vertices at: index - 1.
+ v2 := vertices at: index + 1.
+ epsilon := ((v1 x - v2 x) abs max: (v1 y - v2 y) abs)
+ // 32 max: 1.
+ vert
+ onLineFrom: v1
+ to: v2
+ within: epsilon])
+ ifTrue: [^ index]].
+ ^ 0!
Item was added:
+ ----- Method: PolygonMorph>>nextToFirstPoint (in category 'smoothing') -----
+ nextToFirstPoint
+ "For arrow direction"
+ self isCurvy
+ ifTrue: [curveState
+ ifNil: [self coefficients].
+ ^ curveState second]
+ ifFalse: [^ vertices second]!
Item was added:
+ ----- Method: PolygonMorph>>nextToLastPoint (in category 'smoothing') -----
+ nextToLastPoint
+ "For arrow direction"
+ self isCurvy
+ ifTrue: [curveState
+ ifNil: [self coefficients].
+ ^ curveState third]
+ ifFalse: [^ vertices at: vertices size - 1]!
Item was added:
+ ----- Method: PolygonMorph>>nudgeForLabel: (in category 'attachments') -----
+ nudgeForLabel: aRectangle
+ "Try to move the label off me. Prefer labels on the top and right."
+
+ | i flags nudge |
+ (self bounds intersects: aRectangle) ifFalse: [^ 0 @ 0 ].
+ flags := 0.
+ nudge := 0 @ 0.
+ i := 1.
+ aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg |
+ rectSeg := LineSegment from: rp1 to: rp2.
+ self straightLineSegmentsDo: [ :lp1 :lp2 | | polySeg int |
+ polySeg := LineSegment from: lp1 to: lp2.
+ int := polySeg intersectionWith: rectSeg.
+ int ifNotNil: [ flags := flags bitOr: i ].
+ ].
+ i := i * 2.
+ ].
+ "Now flags has bitflags for which sides"
+ nudge := flags caseOf: {
+ "no intersection"
+ [ 2r0000 ] -> [ 0 @ 0 ].
+ "2 adjacent sides only"
+ [ 2r1001 ] -> [ 1 @ 1 ].
+ [ 2r0011 ] -> [ -1 @ 1 ].
+ [ 2r1100 ] -> [ 1 @ -1 ].
+ [ 2r0110 ] -> [ -1 @ -1 ].
+ "2 opposite sides only"
+ [ 2r1010 ] -> [ 0 @ -1 ].
+ [ 2r0101 ] -> [ 1 @ 0 ].
+ "only 1 side"
+ [ 2r1000 ] -> [ -1 @ 0 ].
+ [ 2r0001 ] -> [ 0 @ -1 ].
+ [ 2r0010 ] -> [ 1 @ 0 ].
+ [ 2r0100 ] -> [ 0 @ 1 ].
+ "3 sides"
+ [ 2r1011 ] -> [ 0 @ 1 ].
+ [ 2r1101 ] -> [ 1 @ 0 ].
+ [ 2r1110 ] -> [ 0 @ -1 ].
+ [ 2r0111 ] -> [ -1 @ 0 ].
+ "all sides"
+ [ 2r1111 ] -> [ 1 @ -1 "move up and to the right" ].
+ }.
+ ^nudge!
Item was added:
+ ----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') -----
+ openOrClosePhrase
+ | curveName |
+ curveName := (self isCurve
+ ifTrue: ['curve']
+ ifFalse: ['polygon']) translated.
+ ^ closed
+ ifTrue: ['make open {1}' translated format: {curveName}]
+ ifFalse: ['make closed {1}' translated format: {curveName}]!
Item was added:
+ ----- Method: PolygonMorph>>privateMoveBy: (in category 'private') -----
+ privateMoveBy: delta
+ super privateMoveBy: delta.
+ vertices := vertices collect: [:p | p + delta].
+ self arrowForms do: [:f | f offset: f offset + delta].
+ curveState := nil. "Force recomputation"
+ (self valueOfProperty: #referencePosition) ifNotNil:
+ [:oldPos | self setProperty: #referencePosition toValue: oldPos + delta]!
Item was added:
+ ----- Method: PolygonMorph>>quickFill: (in category 'menu') -----
+ quickFill: ignored!
Item was added:
+ ----- Method: PolygonMorph>>rectOval (in category 'shaping') -----
+ rectOval
+ "Set my vertices to an array of corner vertices.
+ Order of vertices is in the tradion of warpblt quads."
+
+ self setVertices: self bounds corners.!
Item was added:
+ ----- Method: PolygonMorph>>reduceVertices (in category 'geometry') -----
+ reduceVertices
+ "Reduces the vertices size, when 3 vertices are on the same line with a
+ little epsilon. Based on code by Steffen Mueller"
+ | dup |
+ [ (dup := self nextDuplicateVertexIndex) > 0 ] whileTrue: [
+ self setVertices: (vertices copyWithoutIndex: dup)
+ ].
+ ^vertices size.!
Item was added:
+ ----- Method: PolygonMorph>>referencePosition (in category 'geometry eToy') -----
+ referencePosition
+ "Return the current reference position of the receiver"
+ ^ self valueOfProperty: #referencePosition ifAbsent: [super referencePosition]
+ !
Item was added:
+ ----- Method: PolygonMorph>>releaseCachedState (in category 'caching') -----
+ releaseCachedState
+ super releaseCachedState.
+ filledForm := nil.
+ arrowForms := nil.
+ borderForm := nil.
+ curveState := nil.
+ (self hasProperty: #flex) ifTrue:
+ [self removeProperty: #unflexedVertices;
+ removeProperty: #flex].
+ !
Item was added:
+ ----- Method: PolygonMorph>>removeHandles (in category 'menu') -----
+ removeHandles
+ "tk 9/2/97 allow it to be called twice (when nil already)"
+
+ handles ifNotNil: [
+ handles do: [:h | h delete].
+ handles := nil].!
Item was added:
+ ----- Method: PolygonMorph>>removeVertex: (in category 'dashes') -----
+ removeVertex: aVert
+ "Make sure that I am not left with less than two vertices"
+ | newVertices |
+ vertices size < 2 ifTrue: [ ^self ].
+ newVertices := vertices copyWithout: aVert.
+ newVertices size caseOf: {
+ [1] -> [ newVertices := { newVertices first . newVertices first } ].
+ [0] -> [ newVertices := { aVert . aVert } ]
+ } otherwise: [].
+ self setVertices: newVertices
+ !
Item was added:
+ ----- Method: PolygonMorph>>rotateTestFlip: (in category 'debug and other') -----
+ rotateTestFlip: aBool
+ "Return one copy of me for each vertex using each vertex as
+ the
+ starting point.
+ Vary to border color to destinguish the copies.
+ This tests closed curves for their consistency.
+ The flip boolean tests the reversed rotations."
+ | len colors verts flip |
+ verts := self vertices.
+ flip := aBool == true
+ ifTrue: [1]
+ ifFalse: [0].
+ len := verts size.
+ colors := Color wheel: len*2 .
+ (1 to: len)
+ do: [:i | | j | (self copy
+ borderColor: (colors at: (j:=i * 2 - flip));
+ yourself)
+ setVertices: (verts flipRotated: j);
+ openInWorld]!
Item was added:
+ ----- Method: PolygonMorph>>rotationCenter (in category 'geometry eToy') -----
+ rotationCenter
+ "Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
+ | refPos |
+ refPos := self valueOfProperty: #referencePosition
+ ifAbsent: [^ 0.5 at 0.5].
+ ^ (refPos - self bounds origin) / self bounds extent asFloatPoint!
Item was added:
+ ----- Method: PolygonMorph>>rotationCenter: (in category 'geometry eToy') -----
+ rotationCenter: aPointOrNil
+ "Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
+ | box |
+ aPointOrNil isNil
+ ifTrue: [self removeProperty: #referencePosition]
+ ifFalse: [box := self bounds.
+ self setProperty: #referencePosition
+ toValue: box origin + (aPointOrNil * box extent)]
+ !
Item was added:
+ ----- Method: PolygonMorph>>rotationDegrees (in category 'rotate scale and flex') -----
+ rotationDegrees
+
+ ^ self forwardDirection!
Item was added:
+ ----- Method: PolygonMorph>>rotationDegrees: (in category 'halo control') -----
+ rotationDegrees: degrees
+ | flex center |
+ (center := self valueOfProperty: #referencePosition) ifNil:
+ [self setProperty: #referencePosition toValue: (center := self bounds center)].
+ flex := (MorphicTransform offset: center negated)
+ withAngle: (degrees - self forwardDirection) degreesToRadians.
+ self setVertices: (vertices collect: [:v | (flex transform: v) - flex offset]).
+ self forwardDirection: degrees.
+
+ !
Item was added:
+ ----- Method: PolygonMorph>>setRotationCenterFrom: (in category 'menu') -----
+ setRotationCenterFrom: aPoint
+ "Polygons store their referencePosition."
+ self setProperty: #referencePosition toValue: aPoint!
Item was added:
+ ----- Method: PolygonMorph>>setVertices: (in category 'private') -----
+ setVertices: newVertices
+ vertices := newVertices.
+ handles ifNotNil: [self removeHandles; addHandles].
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>showOrHideHandles (in category 'menu') -----
+ showOrHideHandles
+ self showingHandles
+ ifTrue: [self removeHandles]
+ ifFalse: [self addHandles]!
Item was added:
+ ----- Method: PolygonMorph>>showingHandles (in category 'menu') -----
+ showingHandles
+ ^ handles notNil!
Item was added:
+ ----- Method: PolygonMorph>>slopes: (in category 'smoothing') -----
+ slopes: knots
+ "Choose slopes according to state of polygon and preferences"
+ self isCurvy
+ ifFalse: [^ knots segmentedSlopes].
+ ^ (closed
+ and: [self isCurvier])
+ ifTrue: [knots closedCubicSlopes]
+ ifFalse: [knots naturalCubicSlopes]!
Item was added:
+ ----- Method: PolygonMorph>>smoothOrSegmentedPhrase (in category 'access') -----
+ smoothOrSegmentedPhrase
+ | lineName |
+ lineName := (closed
+ ifTrue: ['outline']
+ ifFalse: ['line']) translated.
+
+ ^ self isCurve
+ ifTrue: ['make segmented {1}' translated format: {lineName}]
+ ifFalse: ['make smooth {1}' translated format: {lineName}].!
Item was added:
+ ----- Method: PolygonMorph>>specifyDashedLine (in category 'menu') -----
+ specifyDashedLine
+
+ | executableSpec newSpec |
+ executableSpec := UIManager default
+ request:
+ 'Enter a dash specification as
+ { major dash length. minor dash length. minor dash color }
+ The major dash will have the normal border color.
+ A blank response will remove the dash specification.
+ [Note: You may give 5 items as, eg, {10. 5. Color white. 0. 3}
+ where the 4th ityem is zero, and the 5th is the number of pixels
+ by which the dashes will move in each step of animation]' translated
+ initialAnswer: '{ 10. 5. Color red }'.
+ executableSpec isEmpty ifTrue:
+ [^ self stopStepping; dashedBorder: nil].
+ newSpec := [Compiler evaluate: executableSpec] ifError:
+ [^ self stopStepping; dashedBorder: nil].
+ newSpec first isNumber & newSpec second isNumber & newSpec third isColor ifFalse:
+ [^ self stopStepping; dashedBorder: nil].
+ newSpec size = 3 ifTrue:
+ [^ self stopStepping; dashedBorder: newSpec].
+ (newSpec size = 5 and: [newSpec fourth isNumber & newSpec fifth isNumber]) ifTrue:
+ [^ self dashedBorder: newSpec; startStepping].
+ !
Item was added:
+ ----- Method: PolygonMorph>>standardArrows (in category 'menu') -----
+ standardArrows
+
+ self removeProperty: #arrowSpec.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>step (in category 'stepping and presenter') -----
+ step
+ borderDashSpec ifNil: [^super step].
+ borderDashSpec size < 5 ifTrue: [^super step].
+
+ "Only for dashed lines with creep"
+ borderDashSpec at: 4 put: (borderDashSpec fourth) + borderDashSpec fifth.
+ self changed.
+ ^super step!
Item was added:
+ ----- Method: PolygonMorph>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ 100!
Item was added:
+ ----- Method: PolygonMorph>>straightLineSegmentsDo: (in category 'smoothing') -----
+ straightLineSegmentsDo: endPointsBlock
+ "Emit a sequence of segment endpoints into endPointsBlock.
+ Work the same way regardless of whether I'm curved."
+ | beginPoint |
+ beginPoint := nil.
+ vertices do:
+ [:vert | beginPoint ifNotNil:
+ [endPointsBlock value: beginPoint
+ value: vert].
+ beginPoint := vert].
+ (closed or: [vertices size = 1])
+ ifTrue: [endPointsBlock value: beginPoint
+ value: vertices first].!
Item was added:
+ ----- Method: PolygonMorph>>straighten (in category 'geometry') -----
+ straighten
+ self setVertices: { vertices first . vertices last }!
Item was added:
+ ----- Method: PolygonMorph>>toggleHandles (in category 'menu') -----
+ toggleHandles
+
+ handles ifNil: [self addHandles] ifNotNil: [self removeHandles].
+
+ !
Item was added:
+ ----- Method: PolygonMorph>>toggleSmoothing (in category 'menu') -----
+ toggleSmoothing
+
+ smoothCurve := smoothCurve not.
+ handles ifNotNil: [self removeHandles; addHandles].
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>totalLength (in category 'attachments') -----
+ totalLength
+ "Answer the full length of my segments. Can take a long time if I'm curved."
+ | length |
+ length := 0.
+ self lineSegmentsDo: [ :a :b | length := length + (a dist: b) ].
+ ^length.!
Item was added:
+ ----- Method: PolygonMorph>>transformVerticesFrom:to: (in category 'private') -----
+ transformVerticesFrom: oldOwner to: newOwner
+ | oldTransform newTransform world newVertices |
+ world := self world.
+ oldTransform := oldOwner
+ ifNil: [ IdentityTransform new ]
+ ifNotNil: [ oldOwner transformFrom: world ].
+ newTransform := newOwner
+ ifNil: [ IdentityTransform new ]
+ ifNotNil: [ newOwner transformFrom: world ].
+ newVertices := vertices collect: [ :ea | newTransform globalPointToLocal:
+ (oldTransform localPointToGlobal: ea) ].
+ self setVertices: newVertices.
+ !
Item was added:
+ ----- Method: PolygonMorph>>transformedBy: (in category 'geometry') -----
+ transformedBy: aTransform
+ self setVertices: (self vertices collect:[:v| aTransform localPointToGlobal: v])!
Item was added:
+ ----- Method: PolygonMorph>>unrotatedLength (in category 'menu') -----
+ unrotatedLength
+ "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is"
+
+ vertices size = 2 ifTrue:
+ [^ (vertices second - vertices first) r].
+
+ ^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height!
Item was added:
+ ----- Method: PolygonMorph>>unrotatedLength: (in category 'menu') -----
+ unrotatedLength: aLength
+ "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is"
+
+ vertices size = 2 ifTrue: [^ self arrowLength: aLength].
+
+ self setVertices: ((((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height: aLength) rotationDegrees: 0) vertices!
Item was added:
+ ----- Method: PolygonMorph>>unrotatedWidth (in category 'menu') -----
+ unrotatedWidth
+ "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is"
+
+ vertices size = 2 ifTrue: [^ self borderWidth].
+ ^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) width!
Item was added:
+ ----- Method: PolygonMorph>>unrotatedWidth: (in category 'menu') -----
+ unrotatedWidth: aWidth
+ "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is"
+
+ self borderWidth: aWidth!
Item was added:
+ ----- Method: PolygonMorph>>updateHandles (in category 'editing') -----
+ updateHandles
+ self isCurvy
+ ifTrue: [handles first center: vertices first.
+ handles last center: vertices last.
+ self midVertices
+ withIndexDo: [:midPt :vertIndex | (closed
+ or: [vertIndex < vertices size])
+ ifTrue: [| newVert |
+ newVert := handles atWrap: vertIndex * 2.
+ newVert position: midPt - (newVert extent // 2)]]]
+ ifFalse: [vertices
+ withIndexDo: [:vertPt :vertIndex |
+ | oldVert |
+ oldVert := handles at: vertIndex * 2 - 1.
+ oldVert position: vertPt - (oldVert extent // 2).
+ (closed
+ or: [vertIndex < vertices size])
+ ifTrue: [| newVert |
+ newVert := handles at: vertIndex * 2.
+ newVert position: vertPt
+ + (vertices atWrap: vertIndex + 1) - newVert extent // 2 + (1 @ -1)]]]!
Item was added:
+ ----- Method: PolygonMorph>>vertexAt: (in category 'dashes') -----
+ vertexAt: n
+ ^vertices at: (n min: vertices size).!
Item was added:
+ ----- Method: PolygonMorph>>vertices (in category 'access') -----
+ vertices
+ ^ vertices!
Item was added:
+ ----- Method: PolygonMorph>>vertices:color:borderWidth:borderColor: (in category 'initialization') -----
+ vertices: verts color: aColor borderWidth: borderWidthInteger borderColor: anotherColor
+ super initialize.
+ ""
+ vertices := verts.
+ color := aColor.
+ borderWidth := borderWidthInteger.
+ borderColor := anotherColor.
+ closed := vertices size > 2.
+ arrows := #none.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') -----
+ verticesAt: ix put: newPoint
+ vertices at: ix put: newPoint.
+ self computeBounds!
Item was added:
+ ----- Method: PolygonMorph>>wantsSteps (in category 'testing') -----
+ wantsSteps
+ super wantsSteps ifTrue: [^true].
+
+ "For crawling ants effect of dashed line."
+ borderDashSpec ifNil: [^false].
+ ^borderDashSpec size = 5 and: [(borderDashSpec fifth) > 0]!
Item was added:
+ StringMorph subclass: #PopUpChoiceMorph
+ instanceVariableNames: 'target actionSelector arguments getItemsSelector getItemsArgs choiceSelector choiceArgs'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: PopUpChoiceMorph>>actionSelector (in category 'as yet unclassified') -----
+ actionSelector
+
+ ^ actionSelector
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>actionSelector: (in category 'as yet unclassified') -----
+ actionSelector: aSymbolOrString
+
+ (nil = aSymbolOrString or:
+ ['nil' = aSymbolOrString or:
+ [aSymbolOrString isEmpty]])
+ ifTrue: [^ actionSelector := nil].
+
+ actionSelector := aSymbolOrString asSymbol.
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>arguments (in category 'as yet unclassified') -----
+ arguments
+
+ ^ arguments
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>arguments: (in category 'as yet unclassified') -----
+ arguments: aCollection
+
+ arguments := aCollection asArray copy.
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>getItemsArgs (in category 'as yet unclassified') -----
+ getItemsArgs
+
+ ^ getItemsArgs
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>getItemsArgs: (in category 'as yet unclassified') -----
+ getItemsArgs: aCollection
+
+ getItemsArgs := aCollection asArray copy.
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>getItemsSelector (in category 'as yet unclassified') -----
+ getItemsSelector
+
+ ^ getItemsSelector
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>getItemsSelector: (in category 'as yet unclassified') -----
+ getItemsSelector: aSymbolOrString
+
+ (nil = aSymbolOrString or:
+ ['nil' = aSymbolOrString or:
+ [aSymbolOrString isEmpty]])
+ ifTrue: [^ getItemsSelector := nil].
+
+ getItemsSelector := aSymbolOrString asSymbol.
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ true
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ self contents: 'PopUpChoice of Colors'.
+ target := Color.
+ actionSelector := nil.
+ arguments := Array empty.
+ getItemsSelector := #colorNames.
+ getItemsArgs := Array empty!
Item was added:
+ ----- Method: PopUpChoiceMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ | items selectedItem |
+ (target isNil or: [getItemsSelector isNil]) ifTrue: [^self].
+ items := ((target perform: getItemsSelector withArguments: getItemsArgs)
+ ifNil: [#()]) asOrderedCollection.
+ selectedItem := UIManager default
+ chooseFrom: items
+ values: items.
+ selectedItem ifNil: [^self].
+ self contentsClipped: selectedItem. "Client can override this if necess"
+ actionSelector ifNotNil:
+ [target perform: actionSelector
+ withArguments: (arguments copyWith: selectedItem)]!
Item was added:
+ ----- Method: PopUpChoiceMorph>>target (in category 'as yet unclassified') -----
+ target
+
+ ^ target
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>target: (in category 'as yet unclassified') -----
+ target: anObject
+
+ target := anObject
+ !
Item was added:
+ ----- Method: PopUpChoiceMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ target := deepCopier references at: target ifAbsent: [target].
+ arguments := arguments collect: [:each |
+ deepCopier references at: each ifAbsent: [each]].
+ getItemsArgs := getItemsArgs collect: [:each |
+ deepCopier references at: each ifAbsent: [each]].
+ choiceArgs ifNotNil: [choiceArgs := choiceArgs collect: [:each |
+ deepCopier references at: each ifAbsent: [each]]].!
Item was added:
+ ----- Method: PopUpChoiceMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ "target := target. Weakly copied"
+ "actionSelector := actionSelector. a Symbol"
+ "arguments := arguments. All weakly copied"
+ "getItemsSelector := getItemsSelector. a Symbol"
+ "getItemsArgs := getItemsArgs. All weakly copied"
+ "choiceSelector := choiceSelector. a Symbol"
+ choiceArgs := choiceArgs. "All weakly copied"
+ !
Item was added:
+ ----- Method: PopUpMenu>>morphicStartUpLeftFlush (in category '*Morphic-Menus') -----
+ morphicStartUpLeftFlush
+ "Build and invoke this menu with no initial selection. By Jerry Archibald, 4/01.
+ If in MVC, align menus items with the left margin.
+ Answer the selection associated with the menu item chosen by the user or nil if none is chosen.
+ The mechanism for getting left-flush appearance in mvc leaves a tiny possibility for misadventure: if the user, in mvc, puts up the jump-to-project menu, then hits cmd period while it is up, then puts up a second jump-to-project menu before dismissing or proceeding through the debugger, it's possible for mvc popup-menus thereafter to appear left-aligned rather than centered; this very unlikely condition can be cleared by evaluating 'PopUpMenu alignment: 2'"
+
+ ^self startUp!
Item was added:
+ ----- Method: PopUpMenu>>morphicStartUpWithCaption:icon:at:allowKeyboard: (in category '*Morphic-Menus') -----
+ morphicStartUpWithCaption: captionOrNil icon: aForm at: location allowKeyboard: aBoolean
+ "Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released,
+ Answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard."
+
+ selection := Cursor normal
+ showWhile: [| menuMorph |
+ menuMorph := MVCMenuMorph from: self title: nil.
+ (captionOrNil notNil
+ or: [aForm notNil])
+ ifTrue: [menuMorph addTitle: captionOrNil icon: aForm].
+ MenuIcons decorateMenu: menuMorph.
+ menuMorph
+ invokeAt: location
+ in: ActiveWorld
+ allowKeyboard: aBoolean].
+ ^ selection!
Item was added:
+ Object subclass: #Presenter
+ instanceVariableNames: ''
+ classVariableNames: 'DefaultPresenterClass'
+ poolDictionaries: ''
+ category: 'Morphic-Worlds'!
+
+ !Presenter commentStamp: '<historical>' prior: 0!
+ Optionally associated with a PasteUpMorph, provides a local scope for the running of scripts.
+
+ Once more valuable, may be again, but at present occupies primarily a historical niche.
+
+ Maintains a playerList cache.
+
+ Holds, optionally three 'standard items' -- standardPlayer standardPlayfield standardPalette -- originally providing idiomatic support of ongoing squeak-team internal work, but now extended to more general applicability.
+
+ !
Item was added:
+ ----- Method: Presenter class>>defaultPresenterClass (in category 'accessing') -----
+ defaultPresenterClass
+ "The default presenter class to use"
+ ^DefaultPresenterClass ifNil:[self]!
Item was added:
+ ----- Method: Presenter class>>defaultPresenterClass: (in category 'accessing') -----
+ defaultPresenterClass: aPresenterClass
+ "The default presenter class to use"
+ DefaultPresenterClass := aPresenterClass!
Item was added:
+ ----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') -----
+ allCurrentlyTickingScriptInstantiations
+ ^#()!
Item was added:
+ ----- Method: Presenter>>allExtantPlayers (in category 'stubs') -----
+ allExtantPlayers
+ ^#()!
Item was added:
+ ----- Method: Presenter>>associatedMorph: (in category 'access') -----
+ associatedMorph: m!
Item was added:
+ ----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') -----
+ browseAllScriptsTextually!
Item was added:
+ ----- Method: Presenter>>currentlyViewing: (in category 'stubs') -----
+ currentlyViewing: aPlayer
+ ^false!
Item was added:
+ ----- Method: Presenter>>drawingJustCompleted: (in category 'stubs') -----
+ drawingJustCompleted: aSketch!
Item was added:
+ ----- Method: Presenter>>flushPlayerListCache (in category 'stubs') -----
+ flushPlayerListCache!
Item was added:
+ ----- Method: Presenter>>morph:droppedIntoPasteUpMorph: (in category 'stubs') -----
+ morph: aMorph droppedIntoPasteUpMorph: aPasteUpMorph!
Item was added:
+ ----- Method: Presenter>>ownStandardPalette (in category 'stubs') -----
+ ownStandardPalette
+ ^nil!
Item was added:
+ ----- Method: Presenter>>positionStandardPlayer (in category 'stubs') -----
+ positionStandardPlayer!
Item was added:
+ ----- Method: Presenter>>viewMorph: (in category 'stubs') -----
+ viewMorph: aMorph
+ aMorph inspect.
+ !
Item was added:
+ ----- Method: Presenter>>viewObjectDirectly: (in category 'stubs') -----
+ viewObjectDirectly: aMorph
+ aMorph inspect.
+ !
Item was added:
+ BorderedMorph subclass: #ProgressBarMorph
+ instanceVariableNames: 'value progressColor lastValue'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: ProgressBarMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu addList: {
+ {'progress color...' translated. #changeProgressColor:}.
+ {'progress value...' translated. #changeProgressValue:}.
+ }!
Item was added:
+ ----- Method: ProgressBarMorph>>changeProgressColor: (in category 'menu') -----
+ changeProgressColor: evt
+ | aHand |
+ aHand := evt ifNotNil: [evt hand] ifNil: [self primaryHand].
+ self changeColorTarget: self selector: #progressColor: originalColor: self progressColor hand: aHand.!
Item was added:
+ ----- Method: ProgressBarMorph>>changeProgressValue: (in category 'menu') -----
+ changeProgressValue: evt
+ | answer |
+ answer := UIManager default
+ request: 'Enter new value (0 - 1.0)'
+ initialAnswer: self value contents asString.
+ answer isEmptyOrNil ifTrue: [^ self].
+ self value contents: answer asNumber!
Item was added:
+ ----- Method: ProgressBarMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | width inner |
+ super drawOn: aCanvas.
+ inner := self innerBounds.
+ width := (inner width * lastValue) truncated min: inner width.
+ aCanvas fillRectangle: (inner origin extent: width @ inner height) color: progressColor.!
Item was added:
+ ----- Method: ProgressBarMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ progressColor := Color green.
+ self value: (ValueHolder new contents: 0.0).
+ lastValue := 0.0!
Item was added:
+ ----- Method: ProgressBarMorph>>progressColor (in category 'accessing') -----
+ progressColor
+ ^progressColor!
Item was added:
+ ----- Method: ProgressBarMorph>>progressColor: (in category 'accessing') -----
+ progressColor: aColor
+ progressColor = aColor
+ ifFalse:
+ [progressColor := aColor.
+ self changed]!
Item was added:
+ ----- Method: ProgressBarMorph>>update: (in category 'updating') -----
+ update: aSymbol
+ aSymbol == #contents
+ ifTrue:
+ [lastValue := value contents.
+ self changed]!
Item was added:
+ ----- Method: ProgressBarMorph>>value (in category 'accessing') -----
+ value
+ ^value!
Item was added:
+ ----- Method: ProgressBarMorph>>value: (in category 'accessing') -----
+ value: aModel
+ value ifNotNil: [value removeDependent: self].
+ value := aModel.
+ value ifNotNil: [value addDependent: self]!
Item was added:
+ RectangleMorph subclass: #ProgressMorph
+ instanceVariableNames: 'labelMorph subLabelMorph progress'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: ProgressMorph class>>example (in category 'example') -----
+ example
+ "ProgressMorph example"
+
+ | progress |
+ progress := ProgressMorph label: 'Test progress'.
+ progress subLabel: 'this is the subheading'.
+ progress openInWorld.
+ [10 timesRepeat:
+ [(Delay forMilliseconds: 200) wait.
+ progress incrDone: 0.1].
+ progress delete] fork!
Item was added:
+ ----- Method: ProgressMorph class>>label: (in category 'instance creation') -----
+ label: aString
+ ^self new label: aString!
Item was added:
+ ----- Method: ProgressMorph>>done (in category 'accessing') -----
+ done
+ ^self progress value contents!
Item was added:
+ ----- Method: ProgressMorph>>done: (in category 'accessing') -----
+ done: amountDone
+ self progress value contents: ((amountDone min: 1.0) max: 0.0).
+ self currentWorld displayWorld!
Item was added:
+ ----- Method: ProgressMorph>>fontOfPointSize: (in category 'private') -----
+ fontOfPointSize: size
+ ^ (TextConstants at: Preferences standardEToysFont familyName ifAbsent: [TextStyle default]) fontOfPointSize: size!
Item was added:
+ ----- Method: ProgressMorph>>incrDone: (in category 'accessing') -----
+ incrDone: incrDone
+ self done: self done + incrDone!
Item was added:
+ ----- Method: ProgressMorph>>initLabelMorph (in category 'initialization') -----
+ initLabelMorph
+ ^ labelMorph := StringMorph contents: '' font: (self fontOfPointSize: 14)!
Item was added:
+ ----- Method: ProgressMorph>>initProgressMorph (in category 'initialization') -----
+ initProgressMorph
+ progress := ProgressBarMorph new.
+ progress borderWidth: 1.
+ progress color: Color white.
+ progress progressColor: Color gray.
+ progress extent: 200 @ 15.
+ !
Item was added:
+ ----- Method: ProgressMorph>>initSubLabelMorph (in category 'initialization') -----
+ initSubLabelMorph
+ ^ subLabelMorph := StringMorph contents: '' font: (self fontOfPointSize: 12)!
Item was added:
+ ----- Method: ProgressMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ self setupMorphs!
Item was added:
+ ----- Method: ProgressMorph>>label (in category 'accessing') -----
+ label
+ ^self labelMorph contents!
Item was added:
+ ----- Method: ProgressMorph>>label: (in category 'accessing') -----
+ label: aString
+ self labelMorph contents: aString.
+ self currentWorld displayWorld!
Item was added:
+ ----- Method: ProgressMorph>>labelMorph (in category 'private') -----
+ labelMorph
+ ^labelMorph ifNil: [self initLabelMorph]!
Item was added:
+ ----- Method: ProgressMorph>>progress (in category 'accessing') -----
+ progress
+ ^progress ifNil: [self initProgressMorph]!
Item was added:
+ ----- Method: ProgressMorph>>setupMorphs (in category 'initialization') -----
+ setupMorphs
+ | |
+ self initProgressMorph.
+ self
+ layoutPolicy: TableLayout new;
+ listDirection: #topToBottom;
+ cellPositioning: #topCenter;
+ listCentering: #center;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ color: Color transparent.
+
+ self addMorphBack: self labelMorph.
+ self addMorphBack: self subLabelMorph.
+ self addMorphBack: self progress.
+
+ self borderWidth: 2.
+ self borderColor: Color black.
+
+ self color: Color veryLightGray.
+ self align: self fullBounds center with: Display boundingBox center
+ !
Item was added:
+ ----- Method: ProgressMorph>>subLabel (in category 'accessing') -----
+ subLabel
+ ^self subLabelMorph contents!
Item was added:
+ ----- Method: ProgressMorph>>subLabel: (in category 'accessing') -----
+ subLabel: aString
+ self subLabelMorph contents: aString.
+ self currentWorld displayWorld!
Item was added:
+ ----- Method: ProgressMorph>>subLabelMorph (in category 'private') -----
+ subLabelMorph
+ ^subLabelMorph ifNil: [self initSubLabelMorph]!
Item was added:
+ ImageMorph subclass: #ProjectViewMorph
+ instanceVariableNames: 'project lastProjectThumbnail'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !ProjectViewMorph commentStamp: '<historical>' prior: 0!
+ I am a Morphic view of a project. I display a scaled version of the project's thumbnail, which itself is a scaled-down snapshot of the screen taken when the project was last exited. When I am displayed, I check to see if the project thumbnail has changed and, if so, I update my own view of that thumbnail.
+ !
Item was added:
+ ----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') -----
+ defaultNameStemForInstances
+ ^ 'ProjectView'!
Item was added:
+ ----- Method: ProjectViewMorph class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') -----
+ fileReaderServicesForFile: fullName suffix: suffix
+
+ ^({ 'extseg'. 'project'. 'pr'. 'morph'. 'morphs'. 'sp'. '*' } includes: suffix)
+ ifTrue: [ self services]
+ ifFalse: [#()]!
Item was added:
+ ----- Method: ProjectViewMorph class>>initialize (in category 'class initialization') -----
+ initialize
+
+ FileList registerFileReader: self!
Item was added:
+ ----- Method: ProjectViewMorph class>>newMVCProject (in category 'project window creation') -----
+ newMVCProject
+ "Create an instance of me on a new MVC project (in a SystemWindow)."
+
+ | proj window |
+ proj := Project new.
+ window := (SystemWindow labelled: proj name) model: proj.
+ window
+ addMorph: (self on: proj)
+ frame: (0 at 0 corner: 1.0 at 1.0).
+ ^ window
+ !
Item was added:
+ ----- Method: ProjectViewMorph class>>newProjectViewInAWindowFor: (in category 'project window creation') -----
+ newProjectViewInAWindowFor: aProject
+ "Return an instance of me on a new Morphic project (in a SystemWindow)."
+
+ | window proj |
+ proj := self on: aProject.
+ window := (SystemWindow labelled: aProject name) model: aProject.
+ window
+ addMorph: proj
+ frame: (0 at 0 corner: 1.0 at 1.0).
+ proj borderWidth: 0.
+ ^ window
+ !
Item was added:
+ ----- Method: ProjectViewMorph class>>on: (in category 'instance creation') -----
+ on: aProject
+
+ ^ self new on: aProject
+ !
Item was added:
+ ----- Method: ProjectViewMorph class>>openFromDirectory:andFileName: (in category 'project window creation') -----
+ openFromDirectory: aDirectory andFileName: aFileName
+
+ Project canWeLoadAProjectNow ifFalse: [^ self].
+ ^ProjectLoading openFromDirectory: aDirectory andFileName: aFileName!
Item was added:
+ ----- Method: ProjectViewMorph class>>openFromDirectoryAndFileName: (in category 'project window creation') -----
+ openFromDirectoryAndFileName: anArray
+
+ Project canWeLoadAProjectNow ifFalse: [^ self].
+ ^ProjectLoading
+ openFromDirectory: anArray first
+ andFileName: anArray second!
Item was added:
+ ----- Method: ProjectViewMorph class>>openFromFile: (in category 'project window creation') -----
+ openFromFile: fileName
+
+ self flag: #bob. "better not to use this one. nil directories are not nice.
+ see #openFromDirectoryAndFileName: or
+ #openFromDirectory:andFileName: instead"
+
+ self halt.
+
+ Project canWeLoadAProjectNow ifFalse: [^ self].
+ ^ProjectLoading openFromDirectory: nil andFileName: fileName!
Item was added:
+ ----- Method: ProjectViewMorph class>>openFromFileList: (in category 'project window creation') -----
+ openFromFileList: fullName
+
+ self flag: #bob. "not sent??"
+
+ self halt.
+
+ ^self openFromFile: fullName!
Item was added:
+ ----- Method: ProjectViewMorph class>>openOn: (in category 'instance creation') -----
+ openOn: aProject
+ "Open a ProjectViewMorph for the project in question"
+ ProjectViewOpenNotification signal ifTrue: [
+ Preferences projectViewsInWindows ifTrue: [
+ (self newProjectViewInAWindowFor: aProject) openInWorld
+ ] ifFalse: [
+ (self on: aProject) openInWorld "but where??"
+ ].
+ ].
+ !
Item was added:
+ ----- Method: ProjectViewMorph class>>serviceOpenProjectFromFile (in category 'project window creation') -----
+ serviceOpenProjectFromFile
+ "Answer a service for opening a .pr project file"
+
+ ^ (SimpleServiceEntry
+ provider: self
+ label: 'load as project'
+ selector: #openFromDirectoryAndFileName:
+ description: 'open project from file'
+ buttonLabel: 'load'
+ )
+ argumentGetter: [ :fileList | fileList dirAndFileName]!
Item was added:
+ ----- Method: ProjectViewMorph class>>services (in category 'fileIn/Out') -----
+ services
+
+ ^ Array with: self serviceOpenProjectFromFile
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph class>>unload (in category 'initialize-release') -----
+ unload
+
+ FileList unregisterFileReader: self !
Item was added:
+ ----- Method: ProjectViewMorph>>abandon (in category 'submorphs-add/remove') -----
+ abandon
+ "Home ViewMorph of project is going away."
+
+ project := nil.
+ super abandon.
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') -----
+ acceptDroppingMorph: morphToDrop event: evt
+
+ | myCopy smallR |
+
+ (self isTheRealProjectPresent) ifFalse: [
+ ^morphToDrop rejectDropMorphEvent: evt. "can't handle it right now"
+ ].
+ (morphToDrop isKindOf: NewHandleMorph) ifTrue: [ "don't send these"
+ ^morphToDrop rejectDropMorphEvent: evt.
+ ].
+ self eToyRejectDropMorph: morphToDrop event: evt. "we will send a copy"
+ myCopy := morphToDrop veryDeepCopy. "gradient fills require doing this second"
+ smallR := (morphToDrop bounds scaleBy: image height / Display height) rounded.
+ smallR := smallR squishedWithin: image boundingBox.
+ image getCanvas
+ paintImage: (morphToDrop imageForm scaledToSize: smallR extent)
+ at: smallR topLeft.
+ myCopy openInWorld: project world
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>addProjectNameMorph (in category 'as yet unclassified') -----
+ addProjectNameMorph
+
+ | m |
+
+ self removeAllMorphs.
+ m := UpdatingStringMorph contents: self safeProjectName font: self fontForName.
+ m target: self; getSelector: #safeProjectName; putSelector: #safeProjectName:.
+ m useStringFormat; fitContents.
+ self addMorphBack: m.
+ self updateNamePosition.
+ ^m
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>addProjectNameMorphFiller (in category 'as yet unclassified') -----
+ addProjectNameMorphFiller
+
+ | m |
+
+ self removeAllMorphs.
+ m := AlignmentMorph newRow color: Color transparent.
+ self addMorphBack: m.
+ m
+ on: #mouseDown send: #editTheName: to: self;
+ on: #mouseUp send: #yourself to: self.
+ self updateNamePosition.
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>balloonText (in category 'events') -----
+ balloonText
+ ^ 'Click here to enter the
+ project named
+ "{1}"' translated format: {project name}!
Item was added:
+ ----- Method: ProjectViewMorph>>borderWidthForRounding (in category 'accessing') -----
+ borderWidthForRounding
+
+ ^1!
Item was added:
+ ----- Method: ProjectViewMorph>>checkForNewerVersionAndLoad (in category 'events') -----
+ checkForNewerVersionAndLoad
+
+ self withProgressDo: [
+ project loadFromServer
+ ]
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>colorAroundName (in category 'drawing') -----
+ colorAroundName
+
+ ^Color gray: 0.8!
Item was added:
+ ----- Method: ProjectViewMorph>>deletingProject: (in category 'events') -----
+ deletingProject: aProject
+ "My project is being deleted. Delete me as well."
+
+ self flag: #bob. "zapping projects"
+
+
+ project == aProject ifTrue: [
+ self owner isSystemWindow ifTrue: [self owner model: nil; delete].
+ self delete].!
Item was added:
+ ----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
+ dismissViaHalo
+ | choice |
+ project ifNil:[^self delete]. "no current project"
+ choice := UIManager default chooseFrom: {
+ 'yes - delete the window and the project' translated.
+ 'no - delete the window only' translated
+ } title: ('Do you really want to delete {1}
+ and all its content?' translated format: {project name printString}).
+ choice = 1 ifTrue:[^self expungeProject].
+ choice = 2 ifTrue:[^self delete].!
Item was added:
+ ----- Method: ProjectViewMorph>>doButtonAction (in category 'events') -----
+ doButtonAction
+ "My inherent button action consists of entering the project I represent"
+
+ self enter!
Item was added:
+ ----- Method: ProjectViewMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ | font projectName nameForm rectForName |
+
+ self ensureImageReady.
+ super drawOn: aCanvas.
+ self isEditingName ifTrue: [^self].
+
+ font := self fontForName.
+ projectName := self safeProjectName.
+ nameForm := (StringMorph contents: projectName font: font) imageForm.
+ nameForm := nameForm scaledToSize: (self extent - (4 at 2) min: nameForm extent).
+ rectForName := self bottomLeft +
+ (self width - nameForm width // 2 @ (nameForm height + 2) negated)
+ extent: nameForm extent.
+ rectForName topLeft eightNeighbors do: [ :pt |
+ aCanvas
+ stencil: nameForm
+ at: pt
+ color: self colorAroundName.
+ ].
+ aCanvas
+ drawImage: nameForm
+ at: rectForName topLeft
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>editTheName: (in category 'as yet unclassified') -----
+ editTheName: evt
+
+ self isTheRealProjectPresent ifFalse: [
+ ^self inform: 'The project is not present and may not be renamed now'
+ ].
+ self addProjectNameMorph launchMiniEditor: evt.!
Item was added:
+ ----- Method: ProjectViewMorph>>ensureImageReady (in category 'drawing') -----
+ ensureImageReady
+
+ self isTheRealProjectPresent ifFalse: [^self].
+ project thumbnail ifNil: [
+ image fill: image boundingBox rule: Form over
+ fillColor: project defaultBackgroundColor.
+ ^self
+ ].
+ project thumbnail ~~ lastProjectThumbnail ifTrue: ["scale thumbnail to fit my bounds"
+ lastProjectThumbnail := project thumbnail.
+ self updateImageFrom: lastProjectThumbnail.
+ project thumbnail ifNotNil: [project thumbnail hibernate].
+ image borderWidth: 1
+ ].
+
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>enter (in category 'events') -----
+ enter
+ "Enter my project."
+
+ self world == self outermostWorldMorph ifFalse: [^Beeper beep]. "can't do this at the moment"
+ project class == DiskProxy
+ ifFalse:
+ [(project world notNil and:
+ [project world isMorph
+ and: [project world hasOwner: self outermostWorldMorph]])
+ ifTrue: [^Beeper beep "project is open in a window already"]].
+ project class == DiskProxy
+ ifTrue:
+ ["When target is not in yet"
+
+ self enterWhenNotPresent. "will bring it in"
+ project class == DiskProxy ifTrue: [^self inform: 'Project not found']].
+ (owner isSystemWindow) ifTrue: [project setViewSize: self extent].
+ self showMouseState: 3.
+ project
+ enter: false
+ revert: false
+ saveForRevert: false!
Item was added:
+ ----- Method: ProjectViewMorph>>enterWhenNotPresent (in category 'events') -----
+ enterWhenNotPresent
+
+ self withProgressDo: [
+ project enter: false revert: false saveForRevert: false. "will bring it in"
+ ]
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>expungeProject (in category 'as yet unclassified') -----
+ expungeProject
+ (self confirm: ('Do you really want to delete {1}
+ and all its content?' translated format: {project name}))
+ ifFalse: [^ self].
+ owner isSystemWindow
+ ifTrue: [owner model: nil;
+ delete].
+ ProjectHistory forget: project.
+ Project deletingProject: project!
Item was added:
+ ----- Method: ProjectViewMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "Set my image form to the given extent."
+
+ | newExtent scaleP scale |
+
+ ((bounds extent = aPoint) and: [image depth = Display depth]) ifFalse: [
+ lastProjectThumbnail ifNil: [ lastProjectThumbnail := image ].
+ scaleP := aPoint / lastProjectThumbnail extent.
+ scale := scaleP "scaleP x asFloat max: scaleP y asFloat".
+ newExtent := (lastProjectThumbnail extent * scale) rounded.
+ self image: (Form extent: newExtent depth: Display depth).
+ self updateImageFrom: lastProjectThumbnail.
+ ].
+ self updateNamePosition.!
Item was added:
+ ----- Method: ProjectViewMorph>>fontForName (in category 'drawing') -----
+ fontForName
+
+ | pickem |
+ pickem := 3.
+
+ pickem = 1 ifTrue: [
+ ^(((TextStyle named: #Helvetica) ifNil: [TextStyle default]) fontOfSize: 13) emphasized: 1.
+ ].
+ pickem = 2 ifTrue: [
+ ^(((TextStyle named: #Palatino) ifNil: [TextStyle default]) fontOfSize: 12) emphasized: 1.
+ ].
+ ^((TextStyle default) fontAt: 1) emphasized: 1
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ true
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>handlesMouseOver: (in category 'event handling') -----
+ handlesMouseOver: evt
+ ^ true!
Item was added:
+ ----- Method: ProjectViewMorph>>handlesMouseOverDragging: (in category 'event handling') -----
+ handlesMouseOverDragging: evt
+
+ ^ true!
Item was added:
+ ----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ "currentBorderColor := Color gray."
+ self addProjectNameMorphFiller.!
Item was added:
+ ----- Method: ProjectViewMorph>>isEditingName (in category 'drawing') -----
+ isEditingName
+
+ | nameMorph |
+ nameMorph := self findA: UpdatingStringMorph.
+ nameMorph ifNil: [^false].
+
+ ^nameMorph hasFocus
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>isTheRealProjectPresent (in category 'drawing') -----
+ isTheRealProjectPresent
+
+ project ifNil: [^ false].
+ project isInMemory ifFalse: [^ false].
+ project class == DiskProxy ifTrue: [^ false].
+ ^true
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>lastProjectThumbnail: (in category 'events') -----
+ lastProjectThumbnail: aForm
+
+ lastProjectThumbnail := aForm!
Item was added:
+ ----- Method: ProjectViewMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+
+ evt yellowButtonPressed ifTrue:
+ [self showMenuForProjectView].
+ evt hand newMouseFocus: self.
+ self removeProperty: #wasOpenedAsSubproject.
+ self showMouseState: 2.!
Item was added:
+ ----- Method: ProjectViewMorph>>mouseEnter: (in category 'event handling') -----
+ mouseEnter: evt
+
+ self showMouseState: 1!
Item was added:
+ ----- Method: ProjectViewMorph>>mouseLeave: (in category 'event handling') -----
+ mouseLeave: evt
+
+ self showMouseState: 3.
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>mouseLeaveDragging: (in category 'event handling') -----
+ mouseLeaveDragging: evt
+
+ self mouseLeave: evt
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+
+ ((self containsPoint: evt cursorPoint) and:
+ [(self hasProperty: #wasOpenedAsSubproject) not]) ifTrue:
+ [^ self enter].
+ self showMouseState: 3.
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>objectForDataStream: (in category 'objects from disk') -----
+ objectForDataStream: refStrm
+
+ | copy |
+
+ 1 = 1 ifTrue: [^self]. "this didn't really work"
+
+ copy := self copy lastProjectThumbnail: nil.
+ "refStrm replace: self with: copy."
+ ^copy
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>on: (in category 'events') -----
+ on: aProject
+
+ project := aProject.
+ self addProjectNameMorphFiller.
+ lastProjectThumbnail := nil.
+ project thumbnail
+ ifNil: [self extent: 100 at 80] "more like screen dimensions?"
+ ifNotNil: [self extent: project thumbnail extent].
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>project (in category 'accessing') -----
+ project
+ ^project!
Item was added:
+ ----- Method: ProjectViewMorph>>project: (in category 'events') -----
+ project: aProject
+
+ project := aProject.
+ self addProjectNameMorphFiller.!
Item was added:
+ ----- Method: ProjectViewMorph>>releaseCachedState (in category 'caching') -----
+ releaseCachedState
+
+ "see if we can reduce size of published file, but there may be problems"
+ super releaseCachedState.
+ lastProjectThumbnail := image.
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>safeProjectName (in category 'drawing') -----
+ safeProjectName
+ | projectName args |
+ projectName := self valueOfProperty: #SafeProjectName ifAbsent: ['???'].
+ self isTheRealProjectPresent
+ ifFalse:
+ [project class == DiskProxy
+ ifTrue:
+ [args := project constructorArgs.
+ ((args isKindOf: Array)
+ and: [args size = 1 and: [args first isString]])
+ ifTrue: [^args first]]
+ ifFalse: [^projectName]].
+ self setProperty: #SafeProjectName toValue: project name.
+ ^project name!
Item was added:
+ ----- Method: ProjectViewMorph>>safeProjectName: (in category 'drawing') -----
+ safeProjectName: aString
+ self addProjectNameMorphFiller.
+ self isTheRealProjectPresent ifFalse: [^self].
+ project renameTo: aString.
+ self setProperty: #SafeProjectName toValue: project name.
+ self updateNamePosition.
+ (owner isSystemWindow) ifTrue: [owner setLabel: aString]!
Item was added:
+ ----- Method: ProjectViewMorph>>seeIfNameChanged (in category 'events') -----
+ seeIfNameChanged
+
+ | nameBefore nameNow |
+
+ nameBefore := self valueOfProperty: #SafeProjectName ifAbsent: ['???'].
+ nameNow := self safeProjectName.
+ (submorphs notEmpty and: [nameBefore = nameNow]) ifTrue: [^self].
+ self addProjectNameMorphFiller.
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>showBorderAs: (in category 'drawing') -----
+ showBorderAs: aColor
+
+ "image border: image boundingBox width: 1 fillColor: aColor.
+ currentBorderColor := aColor.
+ self changed"
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>showMenuForProjectView (in category 'events') -----
+ showMenuForProjectView
+ | menu |
+ (menu := MenuMorph new)
+ add: 'enter this project' translated
+ action: [^ self enter];
+
+ add: 'PUBLISH (also saves a local copy)' translated
+ action: [^ project storeOnServerShowProgressOn: self forgetURL: false];
+
+ add: 'PUBLISH to a different server' translated
+ action: [project forgetExistingURL.
+ ^ project storeOnServerShowProgressOn: self forgetURL: true];
+
+ add: 'see if server version is more recent' translated
+ action: [^ self checkForNewerVersionAndLoad];
+
+ addLine;
+ add: 'expunge this project' translated
+ action: [^ self expungeProject].
+
+ menu title: ('Project Named \"{1}"' translated withCRs format: {project name}).
+ menu invokeModal.!
Item was added:
+ ----- Method: ProjectViewMorph>>showMouseState: (in category 'events') -----
+ showMouseState: anInteger
+ | aMorph |
+ (owner isSystemWindow)
+ ifTrue: [aMorph := owner]
+ ifFalse: [aMorph := self].
+ anInteger = 1
+ ifTrue: ["enter"
+ aMorph
+ addMouseActionIndicatorsWidth: 10
+ color: (Color blue alpha: 0.3)].
+ anInteger = 2
+ ifTrue: ["down"
+ aMorph
+ addMouseActionIndicatorsWidth: 15
+ color: (Color blue alpha: 0.7)].
+ anInteger = 3
+ ifTrue: ["leave"
+ aMorph deleteAnyMouseActionIndicators]!
Item was added:
+ ----- Method: ProjectViewMorph>>step (in category 'stepping and presenter') -----
+ step
+ | cmd |
+ "Check for a command that could not be executed in my subproject. Once it is done, remove the trigger. If this is too slow, make armsLengthCmd an inst var."
+
+ self seeIfNameChanged.
+ cmd := self valueOfProperty: #armsLengthCmd.
+ cmd ifNil: [^ super step].
+ self removeProperty: #armsLengthCmd.
+ project perform: cmd.
+ project enter.!
Item was added:
+ ----- Method: ProjectViewMorph>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^1000!
Item was added:
+ ----- Method: ProjectViewMorph>>storeSegment (in category 'fileIn/out') -----
+ storeSegment
+ "Store my project out on the disk as an ImageSegment. Keep the outPointers in memory. Name it <project name>.seg"
+
+ project storeSegment
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>thumbnail (in category 'accessing') -----
+ thumbnail
+ ^ project ifNotNil: [project thumbnail]!
Item was added:
+ ----- Method: ProjectViewMorph>>triggerActionFromPianoRoll (in category '*Morphic-Sound-piano rolls') -----
+ triggerActionFromPianoRoll
+
+ WorldState addDeferredUIMessage: [
+ project world setProperty: #letTheMusicPlay toValue: true.
+ self enter.
+ ]!
Item was added:
+ ----- Method: ProjectViewMorph>>updateImageFrom: (in category 'drawing') -----
+ updateImageFrom: sourceForm
+
+ (WarpBlt toForm: image)
+ sourceForm: sourceForm;
+ cellSize: 2; "installs a colormap"
+ combinationRule: Form over;
+ copyQuad: (sourceForm boundingBox) innerCorners
+ toRect: image boundingBox.
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>updateNamePosition (in category 'drawing') -----
+ updateNamePosition
+
+ | nameMorph shadowMorph nameFillerMorph |
+
+ (nameMorph := self findA: UpdatingStringMorph) ifNotNil: [
+ nameMorph position:
+ (self left + (self width - nameMorph width // 2)) @
+ (self bottom - nameMorph height - 2).
+ ].
+ (nameFillerMorph := self findA: AlignmentMorph) ifNotNil: [
+ nameFillerMorph
+ position: self bottomLeft - (0 at 20);
+ extent: self width at 20.
+ ].
+ (shadowMorph := self findA: ImageMorph) ifNotNil: [
+ shadowMorph delete "no longer used"
+ ].
+
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ project := deepCopier references at: project ifAbsent: [project].
+ lastProjectThumbnail := deepCopier references at: lastProjectThumbnail
+ ifAbsent: [lastProjectThumbnail].
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared. See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ project := project. "Weakly copied"
+ lastProjectThumbnail := lastProjectThumbnail veryDeepCopyWith: deepCopier.
+ !
Item was added:
+ ----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
+ wantsDroppedMorph: aMorph event: evt
+
+ self isTheRealProjectPresent ifFalse: [^false].
+ project isMorphic ifFalse: [^false].
+ project world viewBox ifNil: [^false]. "uninitialized"
+ ^true!
Item was added:
+ ----- Method: ProjectViewMorph>>wantsKeyboardFocusFor: (in category 'event handling') -----
+ wantsKeyboardFocusFor: aSubmorph
+
+ ^true!
Item was added:
+ ----- Method: ProjectViewMorph>>wantsRoundedCorners (in category 'rounding') -----
+ wantsRoundedCorners
+ ^Preferences roundedWindowCorners
+ and: [(owner isSystemWindow) not]!
Item was added:
+ ----- Method: ProjectViewMorph>>withProgressDo: (in category 'events') -----
+ withProgressDo: aBlock
+
+ ComplexProgressIndicator new
+ targetMorph: self;
+ historyCategory: 'project loading';
+ withProgressDo: aBlock
+ !
Item was added:
+ LayoutPolicy subclass: #ProportionalLayout
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Layouts'!
+
+ !ProportionalLayout commentStamp: '<historical>' prior: 0!
+ I represent a layout that places all children of some morph in their given LayoutFrame.!
Item was added:
+ ----- Method: ProportionalLayout>>isProportionalLayout (in category 'testing') -----
+ isProportionalLayout
+ ^true!
Item was added:
+ ----- Method: ProportionalLayout>>layout:in: (in category 'layout') -----
+ layout: aMorph in: newBounds
+ "Compute the layout for the given morph based on the new bounds"
+ aMorph submorphsDo:[:m| m layoutProportionallyIn: newBounds].!
Item was added:
+ ----- Method: ProportionalLayout>>minExtentOf:in: (in category 'layout') -----
+ minExtentOf: aMorph in: newBounds
+ "Return the minimal size aMorph's children would require given the new bounds"
+ | min |
+ min := 0 at 0.
+ aMorph submorphsDo:[:m| | extent frame |
+ "Map the minimal size of the child through the layout frame.
+ Note: This is done here and not in the child because its specific
+ for proportional layouts. Perhaps we'll generalize this for table
+ layouts but I'm not sure how and when."
+ extent := m minExtent.
+ frame := m layoutFrame.
+ frame ifNotNil:[extent := frame minExtentFrom: extent].
+ min := min max: extent].
+ ^min!
Item was added:
+ AbstractResizerMorph subclass: #ProportionalSplitterMorph
+ instanceVariableNames: 'leftOrTop rightOrBottom splitsTopAndBottom oldColor traceMorph handle movements'
+ classVariableNames: 'SmartHorizontalSplitters SmartVerticalSplitters'
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !ProportionalSplitterMorph commentStamp: 'jmv 1/29/2006 17:16' prior: 0!
+ I am the morph the user grabs to adjust pane splitters.!
Item was added:
+ ----- Method: ProportionalSplitterMorph class>>fastSplitterResize (in category 'preferences') -----
+ fastSplitterResize
+
+ ^ Preferences fastDragWindowForMorphic.!
Item was added:
+ ----- Method: ProportionalSplitterMorph class>>preferenceChanged: (in category 'private') -----
+ preferenceChanged: aBoolean
+ "Take immediate effect for all in a World."
+ self allInstances do:
+ [ : each | (each isInWorld and: [ aBoolean and: [ each wantsSteps ] ])
+ ifTrue: [ each startStepping ]
+ ifFalse: [ each stopStepping ] ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph class>>showSplitterHandles (in category 'preferences') -----
+ showSplitterHandles
+
+ ^ Preferences valueOfPreference: #showSplitterHandles ifAbsent: [true]!
Item was added:
+ ----- Method: ProportionalSplitterMorph class>>smartHorizontalSplitters (in category 'preferences') -----
+ smartHorizontalSplitters
+ <preference: 'Smart Horizontal Splitters'
+ category: 'Morphic'
+ description: 'When true, horizontal splitter bars will automatically reposition themselves to increase the quantity of exposed information, if possible..'
+ type: #Boolean>
+ ^ SmartHorizontalSplitters ifNil: [ false ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph class>>smartHorizontalSplitters: (in category 'preferences') -----
+ smartHorizontalSplitters: aBoolean
+ SmartHorizontalSplitters := aBoolean.
+ self preferenceChanged: aBoolean!
Item was added:
+ ----- Method: ProportionalSplitterMorph class>>smartVerticalSplitters (in category 'preferences') -----
+ smartVerticalSplitters
+ <preference: 'Smart Vertical Splitters'
+ category: 'Morphic'
+ description: 'When true, vertical bars between lists will automatically reposition themselves to balance the number of characters occluded on either side of the bar.'
+ type: #Boolean>
+ ^ SmartVerticalSplitters ifNil: [ false ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph class>>smartVerticalSplitters: (in category 'preferences') -----
+ smartVerticalSplitters: aBoolean
+ SmartVerticalSplitters := aBoolean.
+ self preferenceChanged: aBoolean!
Item was added:
+ ----- Method: ProportionalSplitterMorph class>>splitterWidth (in category 'as yet unclassified') -----
+ splitterWidth
+
+ ^ 4!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>addLeftOrTop: (in category 'controlled morphs') -----
+ addLeftOrTop: aMorph
+
+ leftOrTop add: aMorph!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>addRightOrBottom: (in category 'controlled morphs') -----
+ addRightOrBottom: aMorph
+
+ rightOrBottom add: aMorph.
+
+ !
Item was added:
+ ----- Method: ProportionalSplitterMorph>>beSplitsTopAndBottom (in category 'direction') -----
+ beSplitsTopAndBottom
+
+ splitsTopAndBottom := true.
+ !
Item was added:
+ ----- Method: ProportionalSplitterMorph>>bordersOn: (in category 'controlled morphs') -----
+ bordersOn: aMorph
+ "Answer true if the aMorph is one of my neighbours."
+
+ ^ (leftOrTop includes: aMorph) or: [rightOrBottom includes: aMorph]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>bottomBoundary (in category 'boundaries') -----
+ bottomBoundary
+ "Answert the bottommost x position the receiver could be moved."
+
+ | splitter morphs |
+ splitter := self splitterBelow.
+ morphs := self commonNeighbours: rightOrBottom with: splitter.
+ ^ (splitter
+ ifNil: [owner isSystemWindow ifTrue: [owner panelRect bottom]
+ ifFalse: [owner innerBounds bottom]]
+ ifNotNil: [splitter top])
+ - (self minimumHeightOf: morphs)!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>canEncroachWhiteSpaceOf: (in category 'layout') -----
+ canEncroachWhiteSpaceOf: morphs
+ ^ morphs allSatisfy: [ : each | each canBeEncroached ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>charactersOccludedIn: (in category 'layout') -----
+ charactersOccludedIn: aCollection
+ ^ aCollection
+ inject: 0
+ into:
+ [ : max : each | max max:
+ (each isMorphicModel
+ ifTrue: [ each charactersOccluded ]
+ ifFalse: [ 0 ]) ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>commonNeighbours:with: (in category 'controlled morphs') -----
+ commonNeighbours: morphs with: aProportionalSplitterMorphOrNil
+ "Answer the subset of morphs which is also confined by aProportionalSplitterMorphOrNil."
+
+ ^ aProportionalSplitterMorphOrNil isNil
+ ifTrue: [morphs]
+ ifFalse: [morphs select: [ :which |
+ aProportionalSplitterMorphOrNil bordersOn: which]]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>getOldColor (in category 'displaying') -----
+ getOldColor
+ ^ oldColor ifNil: [Color transparent]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>handleRect (in category 'displaying') -----
+ handleRect
+
+ ^ Rectangle
+ center: self bounds center
+ extent: (self splitsTopAndBottom
+ ifTrue: [self handleSize transposed]
+ ifFalse: [self handleSize])!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>handleSize (in category 'displaying') -----
+ handleSize
+
+ ^ self class splitterWidth @ 30!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+
+ self hResizing: #spaceFill.
+ self vResizing: #spaceFill.
+ splitsTopAndBottom := false.
+
+ leftOrTop := OrderedCollection new.
+ rightOrBottom := OrderedCollection new.
+
+ Preferences showSplitterHandles
+ ifTrue: [
+ handle := CircleMorph new
+ borderWidth: 0;
+ extent: 4 at 4;
+ yourself.
+ handle fillStyle: ((GradientFillStyle
+ ramp: {0.0 -> Preferences defaultWindowColor muchLighter.
+ 1.0 -> Preferences defaultWindowColor darker})
+ origin: handle topLeft;
+ direction: 0 @ handle bounds extent y;
+ normal: handle bounds extent x @ 0;
+ radial: false;
+ yourself).
+ self addMorphCentered: handle].
+ self initializeMovements!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>initializeMovements (in category 'initialization') -----
+ initializeMovements
+ movements := OrderedCollection with: 0 with: 0 with: 0!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>isCursorOverHandle (in category 'displaying') -----
+ isCursorOverHandle
+ ^ self class showSplitterHandles not or: [self handleRect containsPoint: ActiveHand cursorPoint]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>layoutChanged (in category 'layout') -----
+ layoutChanged
+
+ super layoutChanged.
+ handle ifNotNil: [handle position: self bounds center - (2 at 2)]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>leftBoundary (in category 'boundaries') -----
+ leftBoundary
+ "Answer the leftmost y position the receiver could be moved."
+
+ | splitter morphs |
+ splitter := self splitterLeft.
+ morphs := self commonNeighbours: leftOrTop with: splitter.
+ ^ (splitter
+ ifNil: [owner isSystemWindow ifTrue: [owner panelRect left]
+ ifFalse: [owner innerBounds left]]
+ ifNotNil: [splitter right])
+ + (self minimumWidthOf: morphs)!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>leftRightImbalance (in category 'layout') -----
+ leftRightImbalance
+ "First check if I find myself out of range due to user having reduced size of parent."
+ ^ self left < self leftBoundary "too far left"
+ ifTrue: [ self leftBoundary-self left ]
+ ifFalse:
+ [ self right > self rightBoundary "too far right"
+ ifTrue: [ self rightBoundary-self right ]
+ ifFalse: [ self occlusionDifference ] ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>minimumHeightOf: (in category 'boundaries') -----
+ minimumHeightOf: aCollection
+ "Answer the minimum height needed to display any of the morphs in aCollection."
+
+ ^ aCollection inject: 0 into: [ :height :morph |
+ (morph minHeight + self height) max: height]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>minimumWidthOf: (in category 'boundaries') -----
+ minimumWidthOf: aCollection
+ "Answer the minimum width needed to display any of the morphs in aCollection."
+
+ ^ aCollection inject: 0 into: [ :width :morph |
+ (morph minWidth + self width) max: width]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>mouseDown: (in category 'events') -----
+ mouseDown: anEvent
+ "If the user manually drags me, don't override him with auto positioning."
+ anEvent redButtonChanged
+ ifTrue: [ self stopStepping ]
+ ifFalse:
+ [ anEvent shiftPressed
+ ifTrue: [ self startStepping ]
+ ifFalse:
+ [ {self} , self siblingSplitters do:
+ [ : each | each startStepping ] ] ].
+ (self class showSplitterHandles not and: [ self bounds containsPoint: anEvent cursorPoint ]) ifTrue:
+ [ oldColor := self color.
+ self color: Color black ].
+ ^ super mouseDown: anEvent!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>mouseMove: (in category 'events') -----
+ mouseMove: anEvent
+ anEvent hand temporaryCursor
+ ifNil: [^ self].
+ self class fastSplitterResize
+ ifFalse: [self updateFromEvent: anEvent]
+ ifTrue: [traceMorph
+ ifNil: [traceMorph := Morph newBounds: self bounds.
+ traceMorph color: (Color gray alpha: 0.5).
+ traceMorph borderWidth: 0.
+ self owner addMorph: traceMorph].
+ splitsTopAndBottom
+ ifTrue: [traceMorph position: traceMorph position x @ (self normalizedY: anEvent cursorPoint y)]
+ ifFalse: [traceMorph position: (self normalizedX: anEvent cursorPoint x) @ traceMorph position y]]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>mouseUp: (in category 'events') -----
+ mouseUp: anEvent
+ (self bounds containsPoint: anEvent cursorPoint)
+ ifFalse: [anEvent hand showTemporaryCursor: nil].
+ self class fastSplitterResize
+ ifTrue: [self updateFromEvent: anEvent].
+ traceMorph ifNotNil: [traceMorph delete. traceMorph := nil].
+ self color: self getOldColor!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>movements (in category 'layout') -----
+ movements
+ "Used to track my pattern of movement for the last 3 steps to fix the twitching."
+ "Lazy-init for now for smooth transition -- want to convert this back to direct-var access after a few months."
+ ^ movements ifNil: [ self initializeMovements. movements ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>normalizedX: (in category 'boundaries') -----
+ normalizedX: x
+
+ ^ (x max: self leftBoundary) min: self rightBoundary!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>normalizedY: (in category 'boundaries') -----
+ normalizedY: y
+
+ ^ (y max: self topBoundary) min: self bottomBoundary!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>occlusionDifference (in category 'events') -----
+ occlusionDifference
+ ^ (self charactersOccludedIn: leftOrTop) - (self charactersOccludedIn: rightOrBottom)!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>proposedCorrectionWouldCauseFocusChange: (in category 'layout') -----
+ proposedCorrectionWouldCauseFocusChange: correction
+ ^ Preferences mouseOverForKeyboardFocus and:
+ [ | edge | splitsTopAndBottom
+ ifTrue:
+ [ edge := correction positive
+ ifTrue: [ self bottom + 3 ]
+ ifFalse: [ self top - 3 ].
+ ActiveHand position y
+ inRangeOf: edge
+ and: edge + correction ]
+ ifFalse:
+ [ edge := correction positive
+ ifTrue: [ self right ]
+ ifFalse: [ self left ].
+ ActiveHand position x
+ inRangeOf: edge
+ and: edge + correction ] ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>repositionBy: (in category 'layout') -----
+ repositionBy: delta
+ | selfTop selfBottom selfLeft selfRight |
+ leftOrTop do:
+ [ : each | | firstRight firstBottom |
+ firstRight := each layoutFrame rightOffset ifNil: [ 0 ].
+ firstBottom := each layoutFrame bottomOffset ifNil: [ 0 ].
+ each layoutFrame rightOffset: firstRight + delta x.
+ each layoutFrame bottomOffset: firstBottom + delta y ].
+ rightOrBottom do:
+ [ : each | | secondLeft secondTop |
+ secondLeft := each layoutFrame leftOffset ifNil: [ 0 ].
+ secondTop := each layoutFrame topOffset ifNil: [ 0 ].
+ each layoutFrame leftOffset: secondLeft + delta x.
+ each layoutFrame topOffset: secondTop + delta y ].
+ selfTop := self layoutFrame topOffset ifNil: [ 0 ].
+ selfBottom := self layoutFrame bottomOffset ifNil: [ 0 ].
+ selfLeft := self layoutFrame leftOffset ifNil: [ 0 ].
+ selfRight := self layoutFrame rightOffset ifNil: [ 0 ].
+ self layoutFrame
+ topOffset: selfTop + delta y ;
+ bottomOffset: selfBottom + delta y ;
+ leftOffset: selfLeft + delta x ;
+ rightOffset: selfRight + delta x.
+ self owner layoutChanged.
+ self movements removeFirst; add: (splitsTopAndBottom ifTrue: [ delta y sign ] ifFalse: [ delta x sign ])!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>resizeCursor (in category 'displaying') -----
+ resizeCursor
+
+ ^ Cursor resizeForEdge: (splitsTopAndBottom
+ ifTrue: [#top]
+ ifFalse: [#left])
+ !
Item was added:
+ ----- Method: ProportionalSplitterMorph>>rightBoundary (in category 'boundaries') -----
+ rightBoundary
+ "Answer the rightmost x position the receiver could be moved to."
+
+ | splitter morphs |
+ splitter := self splitterRight.
+ morphs := self commonNeighbours: rightOrBottom with: splitter.
+ ^ (splitter
+ ifNil: [owner isSystemWindow ifTrue: [owner panelRect right]
+ ifFalse: [owner innerBounds right]]
+ ifNotNil: [splitter left])
+ - (self minimumWidthOf: morphs)!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>siblingSplitters (in category 'adjacent splitters') -----
+ siblingSplitters
+
+ ^ self owner submorphsSatisfying: [:each | (each isKindOf: self class) and: [self splitsTopAndBottom = each splitsTopAndBottom and: [each ~= self]]]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>splitsTopAndBottom (in category 'direction') -----
+ splitsTopAndBottom
+
+ ^ splitsTopAndBottom!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>splitterAbove (in category 'adjacent splitters') -----
+ splitterAbove
+
+ | splitters |
+ splitters := ((self siblingSplitters select: [:each | each y > self y]) asSortedCollection: [:a :b | a y < b y]).
+
+ ^ splitters ifEmpty: nil ifNotEmpty: [splitters first]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>splitterBelow (in category 'adjacent splitters') -----
+ splitterBelow
+
+ | splitters |
+ splitters := ((self siblingSplitters select: [:each | each y < self y]) asSortedCollection: [:a :b | a y > b y]).
+
+ ^ splitters ifEmpty: nil ifNotEmpty: [splitters first]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>splitterLeft (in category 'adjacent splitters') -----
+ splitterLeft
+
+ | splitters |
+ splitters := ((self siblingSplitters select: [:each | each x < self x]) asSortedCollection: [:a :b | a x > b x]).
+
+ ^ splitters ifEmpty: nil ifNotEmpty: [splitters first]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>splitterRight (in category 'adjacent splitters') -----
+ splitterRight
+
+ | splitters |
+ splitters := ((self siblingSplitters select: [:each | each x > self x]) asSortedCollection: [:a :b | a x < b x]).
+
+ ^ splitters ifEmpty: nil ifNotEmpty: [splitters first]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>step (in category 'events') -----
+ step
+ | correction |
+ splitsTopAndBottom
+ ifTrue:
+ [ (correction := self topBottomCorrection) isZero
+ ifTrue:
+ [ self class smartHorizontalSplitters ifFalse: [ self stopStepping ] ]
+ ifFalse:
+ [ (self proposedCorrectionWouldCauseFocusChange: correction)
+ ifFalse: [ self repositionBy: 0 @ correction ] ] ]
+ ifFalse:
+ [ correction := self leftRightImbalance.
+ correction abs > 1
+ ifTrue:
+ [ (self proposedCorrectionWouldCauseFocusChange: correction)
+ ifFalse:
+ [ self repositionBy:
+ (correction abs > 4
+ ifTrue: [ correction sign * 2 @ 0 ]
+ ifFalse: [ correction sign @ 0 ]) ] ]
+ ifFalse:
+ [ self class smartVerticalSplitters ifFalse: [ self stopStepping ] ] ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>stepTime (in category 'events') -----
+ stepTime
+ "When a splitter finds itself in the right place, let it rest for about 3 seconds to avoid performance impacts of constant, rapid stepping."
+ | pause |
+ pause := 3000. "Frozen image when atRandom failed due to lock on its Mutex."
+ ^ ({#(1 -1 1 ). #(-1 1 -1 )} includes: self movements asArray)
+ ifTrue: [ pause "don't twitch" ]
+ ifFalse:
+ [ splitsTopAndBottom
+ ifTrue:
+ [ self topBottomCorrection isZero
+ ifTrue: [ pause ]
+ ifFalse: [ 0 ] ]
+ ifFalse:
+ [ self leftRightImbalance abs > 1
+ ifTrue: [ ">1 rather than 0 to discourage one-off twitching"
+ 0 ]
+ ifFalse: [ pause ] ] ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>topBottomCorrection (in category 'layout') -----
+ topBottomCorrection
+ "First check if I find myself out of range due to user having reduced size of parent."
+ ^ self bottom < self topBoundary "too high"
+ ifTrue: [ 2 ]
+ ifFalse:
+ [ self top > self bottomBoundary "too low"
+ ifTrue: [ -2 ]
+ ifFalse:
+ [ | wsAbove wsBelow |
+ wsAbove := self canEncroachWhiteSpaceOf: leftOrTop.
+ wsBelow := self canEncroachWhiteSpaceOf: rightOrBottom.
+ wsAbove
+ ifTrue:
+ [ (wsBelow not and: [ self top > (self topBoundary + 25) ])
+ ifTrue: [ -2 ]
+ ifFalse: [ 0 ] ]
+ ifFalse:
+ [ wsBelow
+ ifTrue:
+ [ self bottom < (self bottomBoundary - 25)
+ ifTrue: [ 2 ]
+ ifFalse: [ 0 ] ]
+ ifFalse: [ 0 ] ] ] ]!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>topBoundary (in category 'boundaries') -----
+ topBoundary
+ "Answer the topmost x position the receiver could be moved to."
+
+ | splitter morphs |
+ splitter := self splitterAbove.
+ morphs := self commonNeighbours: leftOrTop with: splitter.
+ ^ (splitter
+ ifNil: [owner isSystemWindow ifTrue: [owner panelRect top]
+ ifFalse: [owner innerBounds top]]
+ ifNotNil: [splitter bottom])
+ + (self minimumHeightOf: morphs)!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>updateFromEvent: (in category 'events') -----
+ updateFromEvent: anEvent
+ | delta |
+ delta := splitsTopAndBottom
+ ifTrue: [ 0 @ ((self normalizedY: anEvent cursorPoint y) - lastMouse y) ]
+ ifFalse: [ (self normalizedX: anEvent cursorPoint x) - lastMouse x @ 0 ].
+ lastMouse := splitsTopAndBottom
+ ifTrue: [ lastMouse x @ (self normalizedY: anEvent cursorPoint y) ]
+ ifFalse: [ (self normalizedX: anEvent cursorPoint x) @ lastMouse y ].
+ self repositionBy: delta!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>wantsEveryMouseMove (in category 'events') -----
+ wantsEveryMouseMove
+
+ ^ true!
Item was added:
+ ----- Method: ProportionalSplitterMorph>>wantsSteps (in category 'events') -----
+ wantsSteps
+ ^ splitsTopAndBottom
+ ifTrue: [ self class smartHorizontalSplitters ]
+ ifFalse: [ self class smartVerticalSplitters ]!
Item was added:
+ SimpleBorder subclass: #RaisedBorder
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Borders'!
+
+ !RaisedBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0!
+ see BorderedMorph!
Item was added:
+ ----- Method: RaisedBorder>>bottomRightColor (in category 'accessing') -----
+ bottomRightColor
+ ^width = 1
+ ifTrue: [color twiceDarker]
+ ifFalse: [color darker]!
Item was added:
+ ----- Method: RaisedBorder>>colorsAtCorners (in category 'accessing') -----
+ colorsAtCorners
+ | c c14 c23 |
+ c := self color.
+ c14 := c lighter. c23 := c darker.
+ ^Array with: c14 with: c23 with: c23 with: c14!
Item was added:
+ ----- Method: RaisedBorder>>style (in category 'accessing') -----
+ style
+ ^#raised!
Item was added:
+ ----- Method: RaisedBorder>>topLeftColor (in category 'accessing') -----
+ topLeftColor
+ ^width = 1
+ ifTrue: [color twiceLighter]
+ ifFalse: [color lighter]!
Item was added:
+ ----- Method: RaisedBorder>>trackColorFrom: (in category 'color tracking') -----
+ trackColorFrom: aMorph
+ baseColor ifNil:[self color: aMorph raisedColor].!
Item was added:
+ ----- Method: Rectangle>>ceiling (in category '*Morphic-Truncation and Roundoff') -----
+ ceiling
+ "Answer the integer rectange to the bottom right of receiver.
+ Return reciever if it already and integerRectange."
+
+ self isIntegerRectangle ifTrue: [ ^ self ] .
+
+ ^origin ceiling corner: corner ceiling!
Item was added:
+ ----- Method: Rectangle>>compressTo: (in category '*Morphic-Truncation and Roundoff') -----
+ compressTo: grid
+ "Answer a Rectangle whose origin and corner are rounded to grid x and grid y.
+ Rounding is done by upper value on origin and lower value on corner so that
+ rounded rectangle is inside self."
+
+ ^Rectangle origin: (origin roundUpTo: grid)
+ corner: (corner roundDownTo: grid)!
Item was added:
+ ----- Method: Rectangle>>compressed (in category '*Morphic-Truncation and Roundoff') -----
+ compressed
+ "Answer a Rectangle whose origin and corner are rounded to integers.
+ Rounding is done by upper value on origin and lower value on corner so that
+ rounded rectangle is inside self."
+
+ ^Rectangle origin: origin ceiling corner: corner floor!
Item was added:
+ ----- Method: Rectangle>>expandTo: (in category '*Morphic-Truncation and Roundoff') -----
+ expandTo: grid
+ "Answer a Rectangle whose origin and corner are rounded to grid x and grid y.
+ Rounding is done by upper value on origin and lower value on corner so that
+ self is inside rounded rectangle."
+
+ ^Rectangle origin: (origin roundDownTo: grid)
+ corner: (corner roundUpTo: grid)!
Item was added:
+ ----- Method: Rectangle>>expanded (in category '*Morphic-Truncation and Roundoff') -----
+ expanded
+ "Answer a Rectangle whose origin and corner are rounded to integers.
+ Rounding is done by upper value on origin and lower value on corner so that
+ self is inside rounded rectangle."
+
+ ^Rectangle origin: origin floor corner: corner ceiling!
Item was added:
+ ----- Method: Rectangle>>floor (in category '*Morphic-Truncation and Roundoff') -----
+ floor
+ "Answer the integer rectange to the topleft of receiver.
+ Return reciever if it already and integerRectange."
+
+ self isIntegerRectangle ifTrue: [ ^ self ] .
+
+ ^origin floor corner: corner floor!
Item was added:
+ ----- Method: Rectangle>>isIntegerRectangle (in category '*Morphic-Truncation and Roundoff') -----
+ isIntegerRectangle
+ "Answer true if all component of receiver are integral."
+
+ ^origin isIntegerPoint and: [ corner isIntegerPoint ]!
Item was added:
+ ----- Method: Rectangle>>roundTo: (in category '*Morphic-Truncation and Roundoff') -----
+ roundTo: grid
+ "Answer a Rectangle whose origin and corner are rounded to grid x and grid y."
+
+ ^Rectangle origin: (origin roundTo: grid)
+ corner: (corner roundTo: grid)!
Item was added:
+ BorderedMorph subclass: #RectangleMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !RectangleMorph commentStamp: 'kfr 10/27/2003 11:12' prior: 0!
+ A subclass of BorderedMorph that supports different fillStyles.
+
+ RectangleMorph diagonalPrototype openInWorld.
+ RectangleMorph gradientPrototype openInWorld.!
Item was added:
+ ----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'Rectangle'
+ categories: #('Graphics' 'Basic')
+ documentation: 'A rectangular shape, with border and fill style'!
Item was added:
+ ----- Method: RectangleMorph class>>diagonalPrototype (in category 'parts bin') -----
+ diagonalPrototype
+
+ | rr |
+ rr := self authoringPrototype.
+ rr useGradientFill; borderWidth: 0.
+ rr fillStyle direction: rr extent.
+ ^ rr!
Item was added:
+ ----- Method: RectangleMorph class>>gradientPrototype (in category 'parts bin') -----
+ gradientPrototype
+
+ | rr |
+ rr := self authoringPrototype.
+ rr useGradientFill; borderWidth: 0.
+ ^ rr!
Item was added:
+ ----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') -----
+ roundRectPrototype
+ ^ self authoringPrototype useRoundedCorners
+ color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5);
+ borderWidth: 1;
+ setNameTo: 'RoundRect'!
Item was added:
+ ----- Method: RectangleMorph>>canHaveFillStyles (in category 'visual properties') -----
+ canHaveFillStyles
+ "Return true if the receiver can have general fill styles; not just colors.
+ This method is for gradually converting old morphs."
+ ^self class == RectangleMorph "no subclasses"!
Item was added:
+ ----- Method: RectangleMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color
+ r: 0.613
+ g: 0.903
+ b: 1.0!
Item was added:
+ ----- Method: RectangleMorph>>wantsToBeCachedByHand (in category 'accessing') -----
+ wantsToBeCachedByHand
+ "Return true if the receiver wants to be cached by the hand when it is dragged around."
+ self hasTranslucentColor ifTrue:[^false].
+ self bounds = self fullBounds ifTrue:[^true].
+ self submorphsDo:[:m|
+ (self bounds containsRect: m fullBounds) ifFalse:[
+ m wantsToBeCachedByHand ifFalse:[^false].
+ ].
+ ].
+ ^true!
Item was added:
+ BorderGripMorph subclass: #RightGripMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: RightGripMorph>>apply: (in category 'target resize') -----
+ apply: delta
+ | oldBounds |
+ oldBounds := target bounds.
+ target
+ bounds: (oldBounds origin corner: oldBounds corner + (delta x @ 0))!
Item was added:
+ ----- Method: RightGripMorph>>defaultWidth (in category 'initialize') -----
+ defaultWidth
+
+ ^ 5!
Item was added:
+ ----- Method: RightGripMorph>>gripLayoutFrame (in category 'accessing') -----
+ gripLayoutFrame
+ ^ LayoutFrame
+ fractions: (1 @ 0 corner: 1 @ 1)
+ offsets: (self defaultWidth negated @ self defaultHeight negated corner: 0@ 0)!
Item was added:
+ ----- Method: RightGripMorph>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ self vResizing: #spaceFill.!
Item was added:
+ ----- Method: RightGripMorph>>ptName (in category 'accessing') -----
+ ptName
+ ^#right!
Item was added:
+ ----- Method: RightGripMorph>>resizeCursor (in category 'accessing') -----
+ resizeCursor
+
+ ^ Cursor resizeForEdge: #right!
Item was added:
+ Morph subclass: #SVColorSelectorMorph
+ instanceVariableNames: 'selectedColor locationMorph'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !SVColorSelectorMorph commentStamp: 'gvc 8/8/2007 14:36' prior: 0!
+ A colour selector that displays an area with saturation on the x axis and volume on the y axis. Provides interactive selection of colour by mouse. For the moment it is event rather than model based.
+ Setting the color will specify the hue and setting the selectedColor will specify the saturation and volume (may have a different hue to that displayed if not in sync).!
Item was added:
+ ----- Method: SVColorSelectorMorph>>adoptPaneColor: (in category 'as yet unclassified') -----
+ adoptPaneColor: paneColor
+ "Pass on to the border too."
+
+ super adoptPaneColor: paneColor.
+ self borderStyle baseColor: paneColor twiceDarker!
Item was added:
+ ----- Method: SVColorSelectorMorph>>basicColor: (in category 'as yet unclassified') -----
+ basicColor: aColor
+ "Set the gradient colors."
+
+ super color: aColor asNontranslucentColor.
+ self
+ fillStyle: self gradient!
Item was added:
+ ----- Method: SVColorSelectorMorph>>blackGradient (in category 'as yet unclassified') -----
+ blackGradient
+ "Answer the black gradient. Top to bottom, transparent to black."
+
+ ^(InterpolatedGradientFillStyle colors: {Color black alpha: 0. Color black})
+ origin: self innerBounds topLeft;
+ direction: 0 at self innerBounds height!
Item was added:
+ ----- Method: SVColorSelectorMorph>>blackGradientMorph (in category 'as yet unclassified') -----
+ blackGradientMorph
+ "Answer the black gradient morph."
+
+ ^Morph new
+ hResizing: #spaceFill;
+ vResizing: #spaceFill;
+ fillStyle: self blackGradient!
Item was added:
+ ----- Method: SVColorSelectorMorph>>borderWidth: (in category 'as yet unclassified') -----
+ borderWidth: anInteger
+ "Update the gradients after setting."
+
+ super borderWidth: anInteger.
+ self updateGradients!
Item was added:
+ ----- Method: SVColorSelectorMorph>>color: (in category 'as yet unclassified') -----
+ color: aColor
+ "Set the gradient colors."
+
+ self
+ basicColor: aColor;
+ selectedColor: (Color h: aColor hue s: self selectedColor saturation v: self selectedColor brightness)!
Item was added:
+ ----- Method: SVColorSelectorMorph>>colorAt: (in category 'as yet unclassified') -----
+ colorAt: aPoint
+ "Answer the color in the world at the given point."
+
+ ^self isInWorld
+ ifTrue: [(Display colorAt: aPoint) asNontranslucentColor ]
+ ifFalse: [Color black]!
Item was added:
+ ----- Method: SVColorSelectorMorph>>extent: (in category 'as yet unclassified') -----
+ extent: p
+ "Update the gradient directions."
+
+ super extent: p.
+ self updateGradients!
Item was added:
+ ----- Method: SVColorSelectorMorph>>fillStyle: (in category 'as yet unclassified') -----
+ fillStyle: fillStyle
+ "If it is a color then override with gradient."
+
+ fillStyle isColor
+ ifTrue: [self color: fillStyle]
+ ifFalse: [super fillStyle: fillStyle]!
Item was added:
+ ----- Method: SVColorSelectorMorph>>gradient (in category 'as yet unclassified') -----
+ gradient
+ "Answer the base gradient."
+
+ |b|
+ b := self innerBounds.
+ ^(GradientFillStyle colors: {Color white. self color})
+ origin: b topLeft;
+ direction: (b width at 0)!
Item was added:
+ ----- Method: SVColorSelectorMorph>>handlesMouseDown: (in category 'as yet unclassified') -----
+ handlesMouseDown: evt
+ "Yes for down and move.."
+
+ ^true!
Item was added:
+ ----- Method: SVColorSelectorMorph>>handlesMouseOverDragging: (in category 'as yet unclassified') -----
+ handlesMouseOverDragging: evt
+ "Yes, make the location morph visible when leaving."
+
+ ^true!
Item was added:
+ ----- Method: SVColorSelectorMorph>>hideLocation (in category 'as yet unclassified') -----
+ hideLocation
+ "Hide the location morph and update the display."
+
+ self locationMorph visible: false.
+ World displayWorldSafely.!
Item was added:
+ ----- Method: SVColorSelectorMorph>>initialize (in category 'as yet unclassified') -----
+ initialize
+ "Initialize the receiver."
+
+ super initialize.
+ self locationMorph: self newLocationMorph.
+ self
+ clipSubmorphs: true;
+ color: Color blue;
+ borderStyle: (BorderStyle inset width: 1);
+ addMorphBack: self locationMorph;
+ addMorphBack: self blackGradientMorph!
Item was added:
+ ----- Method: SVColorSelectorMorph>>layoutBounds: (in category 'as yet unclassified') -----
+ layoutBounds: aRectangle
+ "Set the bounds for laying out children of the receiver.
+ Note: written so that #layoutBounds can be changed without touching this method"
+
+ super layoutBounds: aRectangle.
+ self updateGradients!
Item was added:
+ ----- Method: SVColorSelectorMorph>>locationMorph (in category 'accessing') -----
+ locationMorph
+ "Answer the value of locationMorph"
+
+ ^ locationMorph!
Item was added:
+ ----- Method: SVColorSelectorMorph>>locationMorph: (in category 'accessing') -----
+ locationMorph: anObject
+ "Set the value of locationMorph"
+
+ locationMorph := anObject!
Item was added:
+ ----- Method: SVColorSelectorMorph>>mouseDown: (in category 'as yet unclassified') -----
+ mouseDown: evt
+ "Handle a mouse down event. Select the color at the mouse position."
+
+ evt redButtonPressed
+ ifFalse: [^super mouseDown: evt].
+ evt hand showTemporaryCursor: (Cursor crossHair copy offset: -9 @ -9).
+ self hideLocation.
+ self selectColorAt: evt position.
+ ^super mouseDown: evt!
Item was added:
+ ----- Method: SVColorSelectorMorph>>mouseEnterDragging: (in category 'as yet unclassified') -----
+ mouseEnterDragging: evt
+ "Make the location morph invisible when entering."
+
+ self hideLocation.
+ evt hand showTemporaryCursor: (Cursor crossHair copy offset: -9 @ -9).!
Item was added:
+ ----- Method: SVColorSelectorMorph>>mouseLeaveDragging: (in category 'as yet unclassified') -----
+ mouseLeaveDragging: evt
+ "Make the location morph visible when leaving."
+
+ evt hand showTemporaryCursor: nil.
+ self showLocation!
Item was added:
+ ----- Method: SVColorSelectorMorph>>mouseMove: (in category 'as yet unclassified') -----
+ mouseMove: evt
+ "Handle a mouse move event. Select the color at the mouse position."
+
+ evt redButtonPressed
+ ifFalse: [^super mouseMove: evt].
+ self selectColorAt: evt position.
+ ^super mouseMove: evt!
Item was added:
+ ----- Method: SVColorSelectorMorph>>mouseUp: (in category 'as yet unclassified') -----
+ mouseUp: evt
+ "Handle a up event. Show the location morph again."
+
+ evt hand showTemporaryCursor: nil.
+ self updateSelectedLocation.
+ self locationMorph visible: true!
Item was added:
+ ----- Method: SVColorSelectorMorph>>newLocationMorph (in category 'as yet unclassified') -----
+ newLocationMorph
+ "Answer a new morph indicating the location of the selected color."
+
+ ^ImageMorph new
+ image: Cursor crossHair withMask asCursorForm!
Item was added:
+ ----- Method: SVColorSelectorMorph>>selectColorAt: (in category 'as yet unclassified') -----
+ selectColorAt: aPoint
+ "Set the color at the given position."
+
+ |b p|
+ b := self innerBounds.
+ p := (b containsPoint: aPoint)
+ ifTrue: [aPoint]
+ ifFalse: [b pointNearestTo: aPoint].
+ p := p - b topLeft / b extent.
+ self selectedColor: (Color
+ h: self color hue
+ s: p x
+ v: 1.0 - p y)!
Item was added:
+ ----- Method: SVColorSelectorMorph>>selectedColor (in category 'accessing') -----
+ selectedColor
+ "Answer the value of selectedColor"
+
+ ^selectedColor ifNil: [self color]!
Item was added:
+ ----- Method: SVColorSelectorMorph>>selectedColor: (in category 'accessing') -----
+ selectedColor: aColor
+ "Set the value of selectedColor."
+
+ selectedColor := aColor.
+ self locationMorph visible ifTrue: [self updateSelectedLocation].
+ self triggerEvent: #colorSelected with: aColor!
Item was added:
+ ----- Method: SVColorSelectorMorph>>selectedLocation (in category 'as yet unclassified') -----
+ selectedLocation
+ "Answer the location within the receiver of the selected colour
+ relative to the receiver's top left."
+
+ |b c x y|
+ b := self innerBounds.
+ c := self selectedColor.
+ x := c saturation * (b width - 1).
+ y := 1 - c brightness * (b height - 1).
+ ^(x truncated @ y truncated) + b topLeft!
Item was added:
+ ----- Method: SVColorSelectorMorph>>showLocation (in category 'as yet unclassified') -----
+ showLocation
+ "Show the location morph and update the display."
+
+ self locationMorph visible: true.
+ World displayWorldSafely.!
Item was added:
+ ----- Method: SVColorSelectorMorph>>updateGradients (in category 'as yet unclassified') -----
+ updateGradients
+ "Update the gradient directions."
+
+ |bgm b|
+ b := self innerBounds.
+ bgm := self submorphs last.
+ bgm bounds: b.
+ bgm fillStyle
+ origin: b topLeft;
+ direction: 0 at b height.
+ self fillStyle
+ origin: b topLeft;
+ direction: (b width at 0).
+ self updateSelectedLocation!
Item was added:
+ ----- Method: SVColorSelectorMorph>>updateSelectedLocation (in category 'as yet unclassified') -----
+ updateSelectedLocation
+ "Position the location morph to indicate the selected colour."
+
+ self locationMorph
+ position: (self selectedLocation - (self locationMorph extent // 2 + (self locationMorph extent \\ 2)))!
Item was added:
+ ----- Method: SampledSound>>sonogramMorph:from:to:nPoints: (in category '*Morphic-Sounds-sound tracks') -----
+ sonogramMorph: height from: start to: stop nPoints: nPoints
+ "FYI: It is very cool that we can do this, but for sound tracks on a movie,
+ simple volume is easier to read, easier to scale, and way faster to compute.
+ Code preserved here just in case it makes a useful example."
+ "In an inspector of a samplesSound...
+ self currentWorld addMorph: (self sonogramMorph: 32 from: 1 to: 50000 nPoints: 256)
+ "
+ | fft sonogramMorph width |
+ fft := FFT new: nPoints.
+ width := stop-start//nPoints.
+ sonogramMorph := Sonogram new
+ extent: width at height
+ minVal: 0.0
+ maxVal: 1.0
+ scrollDelta: width.
+ start to: stop-nPoints by: nPoints do:
+ [:i | | data |
+ data := fft transformDataFrom: samples startingAt: i.
+ data := data collect: [:v | v sqrt]. "square root compresses dynamic range"
+ data /= 200.0.
+ sonogramMorph plotColumn: data].
+ ^ sonogramMorph
+
+ !
Item was added:
+ AlignmentMorph subclass: #ScorePlayerMorph
+ instanceVariableNames: 'scorePlayer trackInstNames instrumentSelector scrollSlider'
+ classVariableNames: 'LastMIDIPort'
+ poolDictionaries: ''
+ category: 'Morphic-Sound'!
+
+ !ScorePlayerMorph commentStamp: '<historical>' prior: 0!
+ A ScorePlayerMorph mediates between a score such as a MIDIScore, a PianoRollScoreMorph, and the actual SoundPlayer synthesizer.
+
+ It provides control over volume, tempo, instrumentation, and location in the score.!
Item was added:
+ ----- Method: ScorePlayerMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'ScorePlayer'
+ categories: #('Multimedia')
+ documentation: ' Mediates between a score such as a MIDIScore, a PianoRollScoreMorph, and the actual SoundPlayer synthesizer'!
Item was added:
+ ----- Method: ScorePlayerMorph class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') -----
+ fileReaderServicesForFile: fullName suffix: suffix
+
+ ^(suffix = 'mid') | (suffix = '*')
+ ifTrue: [ self services]
+ ifFalse: [#()]
+ !
Item was added:
+ ----- Method: ScorePlayerMorph class>>initialize (in category 'class initialization') -----
+ initialize
+
+ FileServices registerFileReader: self!
Item was added:
+ ----- Method: ScorePlayerMorph class>>onMIDIFileNamed: (in category 'system hookup') -----
+ onMIDIFileNamed: fileName
+ "Return a ScorePlayerMorph on the score from the MIDI file of the given name."
+
+ | score player |
+ score := MIDIFileReader scoreFromFileNamed: fileName .
+ player := ScorePlayer onScore: score.
+ ^ self new onScorePlayer: player title: fileName
+ !
Item was added:
+ ----- Method: ScorePlayerMorph class>>openOn:title: (in category 'system hookup') -----
+ openOn: aScore title: aString
+
+ | player |
+ player := ScorePlayer onScore: aScore.
+ (self new onScorePlayer: player title: aString) openInWorld.
+ !
Item was added:
+ ----- Method: ScorePlayerMorph class>>playMidiFile: (in category 'class initialization') -----
+ playMidiFile: fullName
+ "Play a MIDI file."
+
+ Smalltalk at: #MIDIFileReader ifPresent: [:midiReader |
+ | f score |
+ f := (FileStream oldFileNamed: fullName) binary.
+ score := (midiReader new readMIDIFrom: f) asScore.
+ f close.
+ self openOn: score title: (FileDirectory localNameFor: fullName)]
+ !
Item was added:
+ ----- Method: ScorePlayerMorph class>>servicePlayMidiFile (in category 'class initialization') -----
+ servicePlayMidiFile
+ "Answer a service for opening player on a midi file"
+
+ ^ SimpleServiceEntry
+ provider: self
+ label: 'open in midi player'
+ selector: #playMidiFile:
+ description: 'open the midi-player tool on this file'
+ buttonLabel: 'open'!
Item was added:
+ ----- Method: ScorePlayerMorph class>>services (in category 'fileIn/Out') -----
+ services
+
+ ^ Array with: self servicePlayMidiFile
+
+ !
Item was added:
+ ----- Method: ScorePlayerMorph class>>unload (in category 'initialize-release') -----
+ unload
+
+ FileServices unregisterFileReader: self !
Item was added:
+ ----- Method: ScorePlayerMorph>>atTrack:from:selectInstrument: (in category 'controls') -----
+ atTrack: trackIndex from: aPopUpChoice selectInstrument: selection
+ | oldSnd name snd |
+ oldSnd := scorePlayer instrumentForTrack: trackIndex.
+ (selection beginsWith: 'edit ')
+ ifTrue:
+ [name := selection copyFrom: 6 to: selection size.
+ aPopUpChoice contentsClipped: name.
+ (oldSnd isKindOf: FMSound) | (oldSnd isKindOf: LoopedSampledSound)
+ ifTrue: [EnvelopeEditorMorph openOn: oldSnd title: name].
+ (oldSnd isKindOf: SampledInstrument)
+ ifTrue: [EnvelopeEditorMorph openOn: oldSnd allNotes first title: name].
+ ^self].
+ snd := nil.
+ 1 to: instrumentSelector size
+ do:
+ [:i |
+ (trackIndex ~= i and: [selection = (instrumentSelector at: i) contents])
+ ifTrue: [snd := scorePlayer instrumentForTrack: i]]. "use existing instrument prototype"
+ snd ifNil:
+ [snd := (selection = 'clink'
+ ifTrue:
+ [(SampledSound samples: SampledSound coffeeCupClink
+ samplingRate: 11025) ]
+ ifFalse: [(AbstractSound soundNamed: selection)]) copy].
+ scorePlayer instrumentForTrack: trackIndex put: snd.
+ (instrumentSelector at: trackIndex) contentsClipped: selection!
Item was added:
+ ----- Method: ScorePlayerMorph>>closeMIDIPort (in category 'initialization') -----
+ closeMIDIPort
+
+ scorePlayer closeMIDIPort.
+ LastMIDIPort := nil.
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 2!
Item was added:
+ ----- Method: ScorePlayerMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color veryLightGray!
Item was added:
+ ----- Method: ScorePlayerMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self listDirection: #topToBottom;
+ wrapCentering: #center;
+ cellPositioning: #topCenter;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ layoutInset: 3;
+ onScorePlayer: ScorePlayer new initialize title: ' ';
+ extent: 20 @ 20 !
Item was added:
+ ----- Method: ScorePlayerMorph>>instrumentChoicesForTrack: (in category 'menu') -----
+ instrumentChoicesForTrack: trackIndex
+ | names |
+ names := AbstractSound soundNames asOrderedCollection.
+ names := names collect: [:n |
+ | inst |
+ inst := AbstractSound soundNamed: n.
+ (inst isKindOf: UnloadedSound)
+ ifTrue: [n, '(out)']
+ ifFalse: [n]].
+ names add: 'clink'.
+ names add: 'edit ', (instrumentSelector at: trackIndex) contents.
+ ^ names asArray
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>invokeMenu (in category 'menu') -----
+ invokeMenu
+ "Invoke a menu of additonal functions for this ScorePlayer."
+
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu add: 'open a MIDI file' translated action: #openMIDIFile.
+ aMenu addList: {
+ #-.
+ {'save as AIFF file' translated. #saveAsAIFF}.
+ {'save as WAV file' translated. #saveAsWAV}.
+ {'save as Sun AU file' translated. #saveAsSunAudio}.
+ #-}.
+ aMenu add: 'reload instruments' translated target: AbstractSound selector: #updateScorePlayers.
+ aMenu addLine.
+ scorePlayer midiPort
+ ifNil: [
+ aMenu add: 'play via MIDI' translated action: #openMIDIPort]
+ ifNotNil: [
+ aMenu add: 'play via built in synth' translated action: #closeMIDIPort.
+ aMenu add: 'new MIDI controller' translated action: #makeMIDIController:].
+ aMenu addLine.
+ aMenu add: 'make a pause marker' translated action: #makeAPauseEvent:.
+
+ aMenu popUpInWorld: self world.
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>makeAPauseEvent: (in category 'menu') -----
+ makeAPauseEvent: evt
+
+ | newWidget |
+
+ newWidget := AlignmentMorph newRow.
+ newWidget
+ color: Color orange;
+ borderWidth: 0;
+ layoutInset: 0;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ extent: 5 at 5;
+ addMorph: (StringMorph contents: '[pause]' translated) lock;
+ addMouseUpActionWith: (
+ MessageSend receiver: self selector: #showResumeButtonInTheWorld
+ ).
+
+ evt hand attachMorph: newWidget.!
Item was added:
+ ----- Method: ScorePlayerMorph>>makeControls (in category 'layout') -----
+ makeControls
+
+ | bb r reverbSwitch repeatSwitch |
+ r := AlignmentMorph newRow.
+ r color: color; borderWidth: 0; layoutInset: 0.
+ r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5 at 5.
+ bb := SimpleButtonMorph new target: self; borderColor: #raised;
+ borderWidth: 2; color: color.
+ r addMorphBack: (bb label: '<>'; actWhen: #buttonDown;
+ actionSelector: #invokeMenu).
+ bb := SimpleButtonMorph new target: self; borderColor: #raised;
+ borderWidth: 2; color: color.
+ r addMorphBack: (bb label: 'Piano Roll' translated; actionSelector: #makePianoRoll).
+ bb := SimpleButtonMorph new target: self; borderColor: #raised;
+ borderWidth: 2; color: color.
+ r addMorphBack: (bb label: 'Rewind' translated; actionSelector: #rewind).
+ bb := SimpleButtonMorph new target: scorePlayer; borderColor: #raised;
+ borderWidth: 2; color: color.
+ r addMorphBack: (bb label: 'Play' translated; actionSelector: #resumePlaying).
+ bb := SimpleButtonMorph new target: scorePlayer; borderColor: #raised;
+ borderWidth: 2; color: color.
+ r addMorphBack: (bb label: 'Pause' translated; actionSelector: #pause).
+ reverbSwitch := SimpleSwitchMorph new
+ offColor: color;
+ onColor: (Color r: 1.0 g: 0.6 b: 0.6);
+ borderWidth: 2;
+ label: 'Reverb Disable' translated;
+ actionSelector: #disableReverb:;
+ target: scorePlayer;
+ setSwitchState: SoundPlayer isReverbOn not.
+ r addMorphBack: reverbSwitch.
+ scorePlayer ifNotNil:
+ [repeatSwitch := SimpleSwitchMorph new
+ offColor: color;
+ onColor: (Color r: 1.0 g: 0.6 b: 0.6);
+ borderWidth: 2;
+ label: 'Repeat' translated;
+ actionSelector: #repeat:;
+ target: scorePlayer;
+ setSwitchState: scorePlayer repeat.
+ r addMorphBack: repeatSwitch].
+ ^ r
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>makeMIDIController: (in category 'layout') -----
+ makeMIDIController: evt
+
+ self world activeHand attachMorph:
+ (MIDIControllerMorph new midiPort: scorePlayer midiPort).
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>makePianoRoll (in category 'layout') -----
+ makePianoRoll
+ "Create a piano roll viewer for this score player."
+
+ | pianoRoll hand |
+ pianoRoll := PianoRollScoreMorph new on: scorePlayer.
+ hand := self world activeHand.
+ hand ifNil: [self world addMorph: pianoRoll]
+ ifNotNil: [hand attachMorph: pianoRoll.
+ hand lastEvent shiftPressed ifTrue:
+ ["Special case for NOBM demo"
+ pianoRoll contractTime; contractTime; enableDragNDrop]].
+ pianoRoll startStepping.
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>makeRow (in category 'layout') -----
+ makeRow
+
+ ^ AlignmentMorph newRow
+ color: color;
+ layoutInset: 0;
+ wrapCentering: #center; cellPositioning: #leftCenter;
+ hResizing: #spaceFill;
+ vResizing: #shrinkWrap
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>onScorePlayer:title: (in category 'initialization') -----
+ onScorePlayer: aScorePlayer title: scoreName
+ | divider col r |
+ scorePlayer := aScorePlayer.
+ scorePlayer ifNotNil:
+ [scorePlayer reset.
+ instrumentSelector := Array new: scorePlayer score tracks size].
+
+ self removeAllMorphs.
+ self addMorphBack: self makeControls.
+ scorePlayer ifNil: [^ self].
+
+ r := self makeRow
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap.
+ r addMorphBack: self rateControl;
+ addMorphBack: (Morph newBounds: (0 at 0 extent: 20 at 0) color: Color transparent);
+ addMorphBack: self volumeControl.
+ self addMorphBack: r.
+ self addMorphBack: self scrollControl.
+
+ col := AlignmentMorph newColumn color: color; layoutInset: 0.
+ self addMorphBack: col.
+ 1 to: scorePlayer trackCount do: [:trackIndex |
+ divider := AlignmentMorph new
+ extent: 10 at 1;
+ borderWidth: 1;
+ layoutInset: 0;
+ borderColor: #raised;
+ color: color;
+ hResizing: #spaceFill;
+ vResizing: #rigid.
+ col addMorphBack: divider.
+ col addMorphBack: (self trackControlsFor: trackIndex)].
+
+ LastMIDIPort ifNotNil: [
+ "use the most recently set MIDI port"
+ scorePlayer openMIDIPort: LastMIDIPort].
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>openMIDIFile (in category 'initialization') -----
+ openMIDIFile
+ "Open a MIDI score and re-init controls..."
+ | score fileName f player |
+ fileName := Utilities chooseFileWithSuffixFromList: #('.mid' '.midi')
+ withCaption: 'Choose a MIDI file to open' translated.
+ (fileName isNil or: [ fileName == #none ])
+ ifTrue: [^ self inform: 'No .mid/.midi files found in the Squeak directory' translated].
+ f := FileStream readOnlyFileNamed: fileName.
+ score := (MIDIFileReader new readMIDIFrom: f binary) asScore.
+ f close.
+ player := ScorePlayer onScore: score.
+ self onScorePlayer: player title: fileName!
Item was added:
+ ----- Method: ScorePlayerMorph>>openMIDIPort (in category 'initialization') -----
+ openMIDIPort
+
+ | portNum |
+ portNum := SimpleMIDIPort outputPortNumFromUser.
+ portNum ifNil: [^ self].
+ scorePlayer openMIDIPort: portNum.
+ LastMIDIPort := portNum.
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>panAndVolControlsFor: (in category 'layout') -----
+ panAndVolControlsFor: trackIndex
+
+ | volSlider panSlider c r middleLine pianoRollColor |
+ pianoRollColor := (Color wheel: scorePlayer score tracks size) at: trackIndex.
+ volSlider := SimpleSliderMorph new
+ color: color;
+ sliderColor: pianoRollColor;
+ extent: 101 at 2;
+ target: scorePlayer;
+ arguments: (Array with: trackIndex);
+ actionSelector: #volumeForTrack:put:;
+ minVal: 0.0;
+ maxVal: 1.0;
+ adjustToValue: (scorePlayer volumeForTrack: trackIndex).
+ panSlider := SimpleSliderMorph new
+ color: color;
+ sliderColor: pianoRollColor;
+ extent: 101 at 2;
+ target: scorePlayer;
+ arguments: (Array with: trackIndex);
+ actionSelector: #panForTrack:put:;
+ minVal: 0.0;
+ maxVal: 1.0;
+ adjustToValue: (scorePlayer panForTrack: trackIndex).
+ c := AlignmentMorph newColumn
+ color: color;
+ layoutInset: 0;
+ wrapCentering: #center; cellPositioning: #topCenter;
+ hResizing: #spaceFill;
+ vResizing: #shrinkWrap.
+ middleLine := Morph new "center indicator for pan slider"
+ color: (Color r: 0.4 g: 0.4 b: 0.4);
+ extent: 1@(panSlider height - 4);
+ position: panSlider center x@(panSlider top + 2).
+ panSlider addMorphBack: middleLine.
+ r := self makeRow.
+ r addMorphBack: (StringMorph contents: '0').
+ r addMorphBack: volSlider.
+ r addMorphBack: (StringMorph contents: '10').
+ c addMorphBack: r.
+ r := self makeRow.
+ r addMorphBack: (StringMorph contents: 'L' translated).
+ r addMorphBack: panSlider.
+ r addMorphBack: (StringMorph contents: 'R' translated).
+ c addMorphBack: r.
+ ^ c
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>rateControl (in category 'layout') -----
+ rateControl
+
+ | rateSlider middleLine r |
+ rateSlider := SimpleSliderMorph new
+ color: color;
+ sliderColor: Color gray;
+ extent: 180 at 2;
+ target: self;
+ actionSelector: #setLogRate:;
+ minVal: -1.0;
+ maxVal: 1.0;
+ adjustToValue: 0.0.
+ middleLine := Morph new "center indicator for pan slider"
+ color: (Color r: 0.4 g: 0.4 b: 0.4);
+ extent: 1@(rateSlider height - 4);
+ position: rateSlider center x@(rateSlider top + 2).
+ rateSlider addMorphBack: middleLine.
+ r := self makeRow
+ hResizing: #shrinkWrap;
+ vResizing: #rigid;
+ height: 24.
+ r addMorphBack: (StringMorph contents: 'slow ' translated).
+ r addMorphBack: rateSlider.
+ r addMorphBack: (StringMorph contents: ' fast' translated).
+ ^ r
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>rewind (in category 'controls') -----
+ rewind
+
+ scorePlayer pause; reset.
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>saveAsAIFF (in category 'menu') -----
+ saveAsAIFF
+ "Create a stereo AIFF audio file with the result of performing my score."
+
+ | fileName |
+ fileName := UIManager default request: 'New file name?' translated.
+ fileName isEmpty ifTrue: [^ self].
+ (fileName asLowercase endsWith: '.aif') ifFalse: [
+ fileName := fileName, '.aif'].
+
+ scorePlayer storeAIFFOnFileNamed: fileName.
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>saveAsSunAudio (in category 'menu') -----
+ saveAsSunAudio
+ "Create a stereo Sun audio file with the result of performing my score."
+
+ | fileName |
+ fileName := UIManager default request: 'New file name?' translated.
+ fileName isEmpty ifTrue: [^ self].
+ (fileName asLowercase endsWith: '.au') ifFalse: [
+ fileName := fileName, '.au'].
+
+ scorePlayer storeSunAudioOnFileNamed: fileName.
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>saveAsWAV (in category 'menu') -----
+ saveAsWAV
+ "Create a stereo WAV audio file with the result of performing my score."
+
+ | fileName |
+ fileName := UIManager default request: 'New file name?' translated.
+ fileName isEmpty ifTrue: [^ self].
+ (fileName asLowercase endsWith: '.wav') ifFalse: [
+ fileName := fileName, '.wav'].
+
+ scorePlayer storeWAVOnFileNamed: fileName.
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>scorePlayer (in category 'accessing') -----
+ scorePlayer
+
+ ^ scorePlayer
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>scrollControl (in category 'layout') -----
+ scrollControl
+
+ | r |
+ scrollSlider := SimpleSliderMorph new
+ color: color;
+ sliderColor: Color gray;
+ extent: 360 at 2;
+ target: scorePlayer;
+ actionSelector: #positionInScore:;
+ adjustToValue: scorePlayer positionInScore.
+ r := self makeRow
+ hResizing: #shrinkWrap;
+ vResizing: #rigid;
+ height: 24.
+ r addMorphBack: (StringMorph contents: 'start ' translated).
+ r addMorphBack: scrollSlider.
+ r addMorphBack: (StringMorph contents: ' end' translated).
+ ^ r
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>setLogRate: (in category 'controls') -----
+ setLogRate: logOfRate
+
+ scorePlayer rate: (3.5 raisedTo: logOfRate).
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>showResumeButtonInTheWorld (in category 'layout') -----
+ showResumeButtonInTheWorld
+ WorldState addDeferredUIMessage: [
+ | w |
+ w := self world.
+ w ifNotNil: [
+ w addMorphFront:
+ (self standaloneResumeButton position: (w right - 100) @ (w top + 10)).
+ scorePlayer pause.
+ ].
+ ]
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>standaloneResumeButton (in category 'layout') -----
+ standaloneResumeButton
+
+ | r |
+
+ r := AlignmentMorph newRow.
+ r color: Color red; borderWidth: 0; layoutInset: 6; useRoundedCorners.
+ r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5 at 5.
+ r addMorphBack: (
+ SimpleButtonMorph new
+ target: [
+ scorePlayer resumePlaying.
+ r delete
+ ];
+ borderColor: #raised;
+ borderWidth: 2;
+ color: Color green;
+ label: 'Continue' translated;
+ actionSelector: #value
+ ).
+ r setBalloonText: 'Continue playing a paused presentation' translated.
+ ^r
+
+
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>step (in category 'stepping and presenter') -----
+ step
+
+ scrollSlider adjustToValue: scorePlayer positionInScore.
+
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>trackControlsFor: (in category 'layout') -----
+ trackControlsFor: trackIndex
+
+ | r |
+ r := self makeRow
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap.
+ r addMorphBack: (self trackNumAndMuteButtonFor: trackIndex).
+ r addMorphBack: (Morph new extent: 10 at 5; color: color). "spacer"
+ r addMorphBack: (self panAndVolControlsFor: trackIndex).
+ ^ r
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>trackNumAndMuteButtonFor: (in category 'layout') -----
+ trackNumAndMuteButtonFor: trackIndex
+
+ | muteButton instSelector pianoRollColor r |
+ muteButton := SimpleSwitchMorph new
+ onColor: (Color r: 1.0 g: 0.6 b: 0.6);
+ offColor: color;
+ color: color;
+ label: 'Mute' translated;
+ target: scorePlayer;
+ actionSelector: #mutedForTrack:put:;
+ arguments: (Array with: trackIndex).
+ instSelector := PopUpChoiceMorph new
+ extent: 95 at 14;
+ contentsClipped: 'oboe1';
+ target: self;
+ actionSelector: #atTrack:from:selectInstrument:;
+ getItemsSelector: #instrumentChoicesForTrack:;
+ getItemsArgs: (Array with: trackIndex).
+ instSelector arguments:
+ (Array with: trackIndex with: instSelector).
+ instrumentSelector at: trackIndex put: instSelector.
+
+ "select track color using same color list as PianoRollScoreMorph"
+ pianoRollColor := (Color wheel: scorePlayer score tracks size) at: trackIndex.
+
+ r := self makeRow
+ hResizing: #rigid;
+ vResizing: #spaceFill;
+ extent: 70 at 10.
+ r addMorphBack:
+ ((StringMorph
+ contents: trackIndex printString
+ font: (TextStyle default fontOfSize: 24)) color: pianoRollColor).
+ trackIndex < 10
+ ifTrue: [r addMorphBack: (Morph new color: color; extent: 19 at 8)] "spacer"
+ ifFalse: [r addMorphBack: (Morph new color: color; extent: 8 at 8)]. "spacer"
+ r addMorphBack:
+ (StringMorph new
+ extent: 140 at 14;
+ contentsClipped: (scorePlayer infoForTrack: trackIndex)).
+ r addMorphBack: (Morph new color: color; extent: 8 at 8). "spacer"
+ r addMorphBack: instSelector.
+ r addMorphBack: (AlignmentMorph newRow color: color). "spacer"
+ r addMorphBack: muteButton.
+ ^ r
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>updateInstrumentsFromLibraryExcept: (in category 'menu') -----
+ updateInstrumentsFromLibraryExcept: soundsBeingEdited
+ "The instrument library has been modified. Update my instruments with the new versions from the library. Use a single instrument prototype for all parts with the same name; this allows the envelope editor to edit all the parts by changing a single sound prototype."
+
+ "soundsBeingEdited is a collection of sounds being edited (by an EnvelopeEditor). If any of my instruments share one of these, then they will be left alone so as not to disturb that dynamic linkage."
+
+ | unloadPostfix myInstruments name displaysAsUnloaded isUnloaded |
+ unloadPostfix := '(out)'.
+ myInstruments := Dictionary new.
+ 1 to: instrumentSelector size do: [:i |
+ name := (instrumentSelector at: i) contents.
+ displaysAsUnloaded := name endsWith: unloadPostfix.
+ displaysAsUnloaded ifTrue: [
+ name := name copyFrom: 1 to: name size - unloadPostfix size].
+ (myInstruments includesKey: name) ifFalse: [
+ myInstruments at: name put:
+ (name = 'clink'
+ ifTrue: [
+ (SampledSound
+ samples: SampledSound coffeeCupClink
+ samplingRate: 11025) copy]
+ ifFalse: [
+ (AbstractSound
+ soundNamed: name
+ ifAbsent: [
+ (instrumentSelector at: i) contentsClipped: 'default'.
+ FMSound default]) copy])].
+ (soundsBeingEdited includes: (scorePlayer instrumentForTrack: i)) ifFalse:
+ ["Do not update any instrument that is currently being edited"
+ scorePlayer instrumentForTrack: i put: (myInstruments at: name)].
+
+ "update loaded/unloaded status in instrumentSelector if necessary"
+ isUnloaded := (myInstruments at: name) isKindOf: UnloadedSound.
+ (displaysAsUnloaded and: [isUnloaded not])
+ ifTrue: [(instrumentSelector at: i) contentsClipped: name].
+ (displaysAsUnloaded not and: [isUnloaded])
+ ifTrue: [(instrumentSelector at: i) contentsClipped: name, unloadPostfix]].
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>volumeControl (in category 'layout') -----
+ volumeControl
+
+ | volumeSlider r |
+ volumeSlider := SimpleSliderMorph new
+ color: color;
+ sliderColor: Color gray;
+ extent: 80 at 2;
+ target: scorePlayer;
+ actionSelector: #overallVolume:;
+ adjustToValue: scorePlayer overallVolume.
+ r := self makeRow
+ hResizing: #shrinkWrap;
+ vResizing: #rigid;
+ height: 24.
+ r addMorphBack: (StringMorph contents: 'soft ' translated).
+ r addMorphBack: volumeSlider.
+ r addMorphBack: (StringMorph contents: ' loud' translated).
+ ^ r
+ !
Item was added:
+ ----- Method: ScorePlayerMorph>>wantsRoundedCorners (in category 'rounding') -----
+ wantsRoundedCorners
+ ^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]!
Item was added:
+ Slider subclass: #ScrollBar
+ instanceVariableNames: 'menuButton upButton downButton pagingArea scrollDelta pageDelta interval menuSelector timeOfMouseDown timeOfLastScroll nextPageDirection currentScrollDelay'
+ classVariableNames: 'ArrowImagesCache BoxesImagesCache RoundedScrollBarLook ScrollBarsWithoutArrowButtons ScrollBarsWithoutMenuButton UpArrow UpArrow8Bit'
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !ScrollBar commentStamp: '<historical>' prior: 0!
+ Inspired by an oiginal design of Hans-Martin Mosner, this ScrollBar is intended to exercise the handling of input events in Morphic. With sufficient flexibility in this area, all particular behavior can be concentrated in this single class with no need to specialize any other morphs to achieve button, slider and menu-button behavior.
+
+ Once we have this working, put in logic for horizontal operation as well.
+
+ CachedImages was added to reduce the number of forms created and thrown away. This will be helpful for Nebraska and others as well.!
Item was added:
+ ----- Method: ScrollBar class>>alwaysShowFlatScrollbarForAlternativeLook (in category 'as yet unclassified') -----
+ alwaysShowFlatScrollbarForAlternativeLook
+ "Set this value to true, if you want to see the flat scrollbar look in flop-out mode as well as inboard. Otherwise the flop-out scrollbar will be rounded and inboard will be flat."
+ ^ false!
Item was added:
+ ----- Method: ScrollBar class>>arrowOfDirection:size:color: (in category 'images') -----
+ arrowOfDirection: aSymbol size: finalSizeInteger color: aColor
+ "answer a form with an arrow based on the parameters"
+ ^ ArrowImagesCache at: {aSymbol. finalSizeInteger. aColor}!
Item was added:
+ ----- Method: ScrollBar class>>arrowSamples (in category 'images - samples') -----
+ arrowSamples
+ "create a set of arrow with different sizes, colors and directions"
+ "
+ ScrollBar arrowSamples.
+ "
+ | column |
+ column := AlignmentMorph newColumn vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
+ layoutInset: 1;
+ borderColor: Color black;
+ borderWidth: 0;
+ wrapCentering: #center;
+ cellPositioning: #center;
+ color: Color white;
+ yourself.
+
+ self sampleSizes
+ do: [:size |
+ | row |
+ row := AlignmentMorph newRow color: Color transparent;
+ vResizing: #shrinkWrap;
+ cellInset: 2 @ 0 yourself.
+
+ self sampleColors
+ do: [:color |
+ #(#top #right #bottom #left )
+ do: [:direction |
+ row addMorphBack: (ScrollBar
+ arrowOfDirection: direction
+ size: size
+ color: color) asMorph]].
+
+ column addMorphBack: row].
+
+ column openInHand!
Item was added:
+ ----- Method: ScrollBar class>>boxOfSize:color: (in category 'images') -----
+ boxOfSize: finalSizeInteger color: aColor
+ "answer a form with an box based on the parameters"
+ ^ BoxesImagesCache at: {finalSizeInteger. aColor}!
Item was added:
+ ----- Method: ScrollBar class>>boxSamples (in category 'images - samples') -----
+ boxSamples
+ "create a set of box with different sizes and colors"
+ "
+ ScrollBar boxSamples.
+ "
+ | column |
+ column := AlignmentMorph newColumn vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
+ layoutInset: 1;
+ borderColor: Color black;
+ borderWidth: 0;
+ wrapCentering: #center;
+ cellPositioning: #center;
+ color: Color white;
+ yourself.
+ ""
+ self sampleSizes
+ do: [:size |
+ | row |
+ row := AlignmentMorph newRow color: Color transparent;
+ vResizing: #shrinkWrap;
+ cellInset: 2 @ 0 yourself.
+ ""
+ self sampleColors
+ do: [:color |
+ row addMorphBack: (ScrollBar boxOfSize: size color: color) asMorph].
+ ""
+ column addMorphBack: row].
+ ""
+ ""
+ column openInHand!
Item was added:
+ ----- Method: ScrollBar class>>changesInPreferences (in category 'images') -----
+ changesInPreferences
+ "the related preferences changed"
+ self initializeImagesCache
+ " ScrollBar allInstances do: [:each | each removeAllMorphs; initializeSlider] "!
Item was added:
+ ----- Method: ScrollBar class>>cleanUp (in category 'class initialization') -----
+ cleanUp
+ "Re-initialize the image cache"
+
+ self initializeImagesCache!
Item was added:
+ ----- Method: ScrollBar class>>createArrowImagesCache (in category 'class initialization') -----
+ createArrowImagesCache
+ "creates the cache to store the arrow forms"
+ ^ LRUCache
+ size: 40
+ factory: [:key | ""
+ self
+ createArrowOfDirection: key first
+ size: key second
+ color: key third]!
Item was added:
+ ----- Method: ScrollBar class>>createArrowOfDirection:in: (in category 'images') -----
+ createArrowOfDirection: aSymbol in: aRectangle
+ "PRIVATE - create an arrow bounded in aRectangle"
+
+ | arrow vertices |
+ vertices := Preferences alternativeButtonsInScrollBars
+ ifTrue: [self verticesForComplexArrow: aRectangle]
+ ifFalse: [self verticesForSimpleArrow: aRectangle].
+ ""
+ arrow := PolygonMorph
+ vertices: vertices
+ color: Color transparent
+ borderWidth: 0
+ borderColor: Color black.
+ ""
+ arrow bounds: (arrow bounds insetBy: (aRectangle width / 6) rounded).
+ ""
+ Preferences alternativeButtonsInScrollBars
+ ifTrue: [arrow rotationDegrees: 45].
+ ""
+ aSymbol == #right
+ ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 90].
+ aSymbol == #bottom
+ ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 180].
+ aSymbol == #left
+ ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 270].
+ ""
+ ^arrow!
Item was added:
+ ----- Method: ScrollBar class>>createArrowOfDirection:size:color: (in category 'images') -----
+ createArrowOfDirection: aSymbolDirection size: finalSizeInteger color: aColor
+ "PRIVATE - create an arrow with aSymbolDirectionDirection,
+ finalSizeInteger and aColor
+
+ aSymbolDirectionDirection = #top, #bottom. #left or #right
+
+ Try with:
+ (ScrollBar createArrowOfDirection: #top size: 32 color: Color
+ lightGreen) asMorph openInHand.
+ "
+ | resizeFactor outerBox arrow resizedForm gradient |
+ resizeFactor := 4.
+ outerBox := RectangleMorph new
+ extent: finalSizeInteger asPoint * resizeFactor;
+ borderWidth: 0;
+ color: aColor.
+
+ Preferences gradientScrollBars ifTrue: [
+ gradient := GradientFillStyle ramp: {
+ 0 -> (Color gray: 0.95).
+ 0.49 -> (Color gray: 0.9).
+ 0.5 -> (Color gray: 0.87).
+ 1 -> (Color gray: 0.93).
+ }.
+ gradient origin: outerBox topLeft.
+ (aSymbolDirection == #left or:[aSymbolDirection == #right])
+ ifTrue:[gradient direction: 0@ outerBox height]
+ ifFalse:[gradient direction: outerBox width @ 0].
+ outerBox fillStyle: gradient].
+ outerBox borderStyle: (BorderStyle width: 4 color: Color lightGray).
+
+ ""
+ arrow := self createArrowOfDirection: aSymbolDirection in: (outerBox bounds expandBy: -4).
+ self updateScrollBarButtonAspect: arrow color: aColor muchDarker.
+ outerBox addMorphCentered: arrow.
+ ""
+ resizedForm := outerBox imageForm
+ magnify: outerBox imageForm boundingBox
+ by: 1 / resizeFactor
+ smoothing: 4.
+ ""
+ ^ (resizedForm replaceColor: aColor withColor: Color transparent)
+ trimBordersOfColor: Color transparent!
Item was added:
+ ----- Method: ScrollBar class>>createBoxImagesCache (in category 'class initialization') -----
+ createBoxImagesCache
+ "creates the cache to store the arrow forms"
+ ^ LRUCache
+ size: 20
+ factory: [:key | self createBoxOfSize: key first color: key second]!
Item was added:
+ ----- Method: ScrollBar class>>createBoxIn: (in category 'images') -----
+ createBoxIn: aRectangle
+ "PRIVATE - create an box bounded in aRectangle"
+ | box |
+ box := RectangleMorph new.
+ box extent: (aRectangle scaleBy: 1 / 2) extent rounded;
+ borderWidth: 0.
+ ""
+ ^ box!
Item was added:
+ ----- Method: ScrollBar class>>createBoxOfSize:color: (in category 'images') -----
+ createBoxOfSize: finalSizeInteger color: aColor
+ "PRIVATE - create a box with finalSizeInteger and aColor
+
+ Try with:
+ (ScrollBar createBoxOfSize: 32 color: Color lightGreen) asMorph
+ openInHand.
+ "
+ | resizeFactor outerBox innerBox resizedForm gradient |
+ resizeFactor := 4.
+ outerBox := RectangleMorph new
+ extent: finalSizeInteger asPoint * resizeFactor;
+ borderWidth: 0;
+ color: aColor.
+ Preferences gradientScrollBars ifTrue: [
+ gradient := GradientFillStyle ramp: {
+ 0 -> (Color gray: 0.95).
+ 0.49 -> (Color gray: 0.9).
+ 0.5 -> (Color gray: 0.87).
+ 1 -> (Color gray: 0.93).
+ }.
+ gradient origin: outerBox topLeft.
+ gradient direction: outerBox width @ 0.
+ outerBox fillStyle: gradient].
+ outerBox borderStyle: (BorderStyle width: 4 color: Color lightGray).
+ ""
+ innerBox := self createBoxIn: (outerBox bounds expandBy: -4).
+ self updateScrollBarButtonAspect: innerBox color: aColor muchDarker.
+ outerBox addMorphCentered: innerBox.
+ ""
+ resizedForm := outerBox imageForm
+ magnify: outerBox imageForm boundingBox
+ by: 1 / resizeFactor
+ smoothing: 4.
+ ""
+ ^ (resizedForm replaceColor: aColor withColor: Color transparent)
+ trimBordersOfColor: Color transparent!
Item was added:
+ ----- Method: ScrollBar class>>initialize (in category 'class initialization') -----
+ initialize
+ "ScrollBar initialize"
+ UpArrow := Form
+ extent: 6 @ 3
+ fromArray: #(805306368 2013265920 4227858432 )
+ offset: 0 @ 0.
+ ""
+ self initializeImagesCache.
+
+ "Adjustments for FaceLift"
+ Preferences disable: #scrollBarsNarrow.
+ SystemWindow allSubInstancesDo:[:w| w updatePaneColors].
+ ScrollPane allSubInstancesDo:[:pane| pane hideOrShowScrollBars].
+ !
Item was added:
+ ----- Method: ScrollBar class>>initializeImagesCache (in category 'class initialization') -----
+ initializeImagesCache
+ "initialize the receiver's ImagesCache.
+
+ normally this method is not evaluated more than in the class
+ initializazion. "
+
+ "
+ ScrollBar initializeImagesCache.
+ "
+
+ ArrowImagesCache := self createArrowImagesCache.
+ BoxesImagesCache := self createBoxImagesCache!
Item was added:
+ ----- Method: ScrollBar class>>refreshAllScrollBars (in category 'class initialization') -----
+ refreshAllScrollBars
+
+ ScrollBar allSubInstances do: [:s |
+ s updateSlider].!
Item was added:
+ ----- Method: ScrollBar class>>roundedScrollBarLook (in category 'preferences') -----
+ roundedScrollBarLook
+
+ <preference: 'roundedScrollBarLook'
+ category: #scrolling
+ description: 'If true, morphic scrollbars will look rounded.'
+ type: #Boolean>
+ ^ RoundedScrollBarLook ifNil: [false]!
Item was added:
+ ----- Method: ScrollBar class>>roundedScrollBarLook: (in category 'preferences') -----
+ roundedScrollBarLook: aBoolean
+
+ RoundedScrollBarLook := aBoolean.!
Item was added:
+ ----- Method: ScrollBar class>>sampleColors (in category 'images - samples') -----
+ sampleColors
+ "private"
+ ^ (Color lightCyan wheel: 5)!
Item was added:
+ ----- Method: ScrollBar class>>sampleSizes (in category 'images - samples') -----
+ sampleSizes
+
+ "private"
+ ^ #(10 12 14 16 18 32 64 )!
Item was added:
+ ----- Method: ScrollBar class>>scrollBarsWithoutArrowButtons (in category 'preferences') -----
+ scrollBarsWithoutArrowButtons
+
+ <preference: 'scrollBarsWithoutArrowButtons'
+ category: #scrolling
+ description: 'If true, morphic scrollbars will not include arrow buttons but only the slider.'
+ type: #Boolean>
+ ^ ScrollBarsWithoutArrowButtons ifNil: [false]!
Item was added:
+ ----- Method: ScrollBar class>>scrollBarsWithoutArrowButtons: (in category 'preferences') -----
+ scrollBarsWithoutArrowButtons: aBoolean
+
+ ScrollBarsWithoutArrowButtons = aBoolean ifTrue: [^ self].
+ ScrollBarsWithoutArrowButtons := aBoolean.
+ self refreshAllScrollBars.!
Item was added:
+ ----- Method: ScrollBar class>>scrollBarsWithoutMenuButton (in category 'preferences') -----
+ scrollBarsWithoutMenuButton
+
+ <preference: 'scrollBarsWithoutMenuButton'
+ category: #scrolling
+ description: 'If true, morphic scrollbars will not include a menu button.'
+ type: #Boolean>
+ ^ ScrollBarsWithoutMenuButton ifNil: [false]!
Item was added:
+ ----- Method: ScrollBar class>>scrollBarsWithoutMenuButton: (in category 'preferences') -----
+ scrollBarsWithoutMenuButton: aBoolean
+
+ ScrollBarsWithoutMenuButton = aBoolean ifTrue: [^ self].
+ ScrollBarsWithoutMenuButton := aBoolean.
+ self refreshAllScrollBars.!
Item was added:
+ ----- Method: ScrollBar class>>updateScrollBarButtonAspect:color: (in category 'coloring morphs') -----
+ updateScrollBarButtonAspect: aMorph color: aColor
+ "update aMorph with aColor"
+ | fill direction |
+ aMorph isNil
+ ifTrue: [^ self].
+ ""
+ aMorph color: aColor.
+ Preferences gradientScrollBars
+ ifFalse: [^ self].
+ ""
+ fill := GradientFillStyle ramp: {
+ 0.0 -> aColor twiceLighter twiceLighter.
+ 1.0 -> aColor twiceDarker}.
+ ""
+ direction := ((aMorph width min: aMorph height)
+ + ((aMorph width - aMorph height) abs * 0.3)) rounded.
+ ""
+ fill origin: aMorph topLeft + (direction // 8).
+ fill direction: direction @ direction.
+ fill radial: true.
+ ""
+ aMorph fillStyle: fill!
Item was added:
+ ----- Method: ScrollBar class>>updateScrollBarButtonsAspect:color: (in category 'coloring morphs') -----
+ updateScrollBarButtonsAspect: aCollection color: aColor
+ "update aCollection of morphs with aColor"
+
+
+ aCollection
+ do: [:each | self updateScrollBarButtonAspect: each color: aColor]!
Item was added:
+ ----- Method: ScrollBar class>>verticesForComplexArrow: (in category 'images') -----
+ verticesForComplexArrow: aRectangle
+ "PRIVATE - answer a collection of vertices to draw a complex arrow"
+ | vertices aux |
+ vertices := OrderedCollection new.
+ ""
+ vertices add: aRectangle bottomLeft.
+ vertices add: aRectangle topLeft.
+ vertices add: aRectangle topRight.
+ ""
+ aux := (aRectangle width / 3) rounded.
+ vertices add: aRectangle topRight + (0 @ aux).
+ vertices add: aRectangle topLeft + aux.
+ vertices add: aRectangle bottomLeft + (aux @ 0).
+ ""
+ ^ vertices!
Item was added:
+ ----- Method: ScrollBar class>>verticesForSimpleArrow: (in category 'images') -----
+ verticesForSimpleArrow: aRectangle
+ "PRIVATE - answer a collection of vertices to draw a simple arrow"
+ | vertices |
+ vertices := OrderedCollection new.
+ ""
+ vertices add: aRectangle bottomLeft.
+ vertices add: aRectangle center x @ (aRectangle top + (aRectangle width / 8)).
+ vertices add: aRectangle bottomRight.
+ ""
+ ^ vertices!
Item was added:
+ ----- Method: ScrollBar>>adoptPaneColor: (in category 'access') -----
+ adoptPaneColor: aColor
+ "Adopt the given pane color"
+ aColor ifNil:[^self].
+ self sliderColor: aColor.!
Item was added:
+ ----- Method: ScrollBar>>boundsForDownButton (in category 'initialize') -----
+ boundsForDownButton
+
+ ^ self innerBounds bottomRight - self buttonExtent
+ extent: self buttonExtent!
Item was added:
+ ----- Method: ScrollBar>>boundsForMenuButton (in category 'initialize') -----
+ boundsForMenuButton
+
+ ^ self innerBounds topLeft extent: self buttonExtent!
Item was added:
+ ----- Method: ScrollBar>>boundsForUpButton (in category 'initialize') -----
+ boundsForUpButton
+
+ ^ (self menuButton visible
+ ifFalse: [self innerBounds topLeft]
+ ifTrue: [bounds isWide
+ ifTrue: [self menuButton bounds topRight - (1 at 0)]
+ ifFalse: [self menuButton bounds bottomLeft - (0 at 1)]])
+ extent: self buttonExtent!
Item was added:
+ ----- Method: ScrollBar>>buttonExtent (in category 'geometry') -----
+ buttonExtent
+ ^ bounds isWide
+ ifTrue: [self innerBounds height asPoint]
+ ifFalse: [self innerBounds width asPoint]!
Item was added:
+ ----- Method: ScrollBar>>defaultBorderWidth (in category 'initialize') -----
+ defaultBorderWidth
+ ^ 0!
Item was added:
+ ----- Method: ScrollBar>>doScrollByPage (in category 'scrolling') -----
+ doScrollByPage
+ "Scroll automatically while mouse is down"
+ (self waitForDelay1: 300 delay2: 100) ifFalse: [^ self].
+ nextPageDirection
+ ifTrue: [self setValue: value + pageDelta]
+ ifFalse: [self setValue: value - pageDelta]
+ !
Item was added:
+ ----- Method: ScrollBar>>doScrollDown (in category 'scrolling') -----
+ doScrollDown
+ "Scroll automatically while mouse is down"
+ (self waitForDelay1: 200 delay2: 40) ifFalse: [^ self].
+ self setValue: value + scrollDelta.!
Item was added:
+ ----- Method: ScrollBar>>doScrollUp (in category 'scrolling') -----
+ doScrollUp
+ "Scroll automatically while mouse is down"
+ (self waitForDelay1: 200 delay2: 40) ifFalse: [^ self].
+ self setValue: value - scrollDelta.!
Item was added:
+ ----- Method: ScrollBar>>downImage (in category 'initialize') -----
+ downImage
+ "answer a form to be used in the down button"
+ ^ self class
+ arrowOfDirection: (bounds isWide
+ ifTrue: [#right]
+ ifFalse: [#bottom])
+ size: (self buttonExtent x min: self buttonExtent y)
+ color: self thumbColor!
Item was added:
+ ----- Method: ScrollBar>>expandSlider (in category 'geometry') -----
+ expandSlider
+ "Compute the new size of the slider (use the old sliderThickness as a minimum)."
+ | r |
+ r := self totalSliderArea.
+ slider extent: (bounds isWide
+ ifTrue: [((r width * self interval) asInteger max: self sliderThickness) @ slider height]
+ ifFalse: [slider width @ ((r height * self interval) asInteger max: self sliderThickness)])!
Item was added:
+ ----- Method: ScrollBar>>extent: (in category 'geometry') -----
+ extent: p
+ p x > p y
+ ifTrue: [super
+ extent: (p max: 42 @ 8)]
+ ifFalse: [super
+ extent: (p max: 8 @ 42)].
+ !
Item was added:
+ ----- Method: ScrollBar>>finishedScrolling (in category 'scrolling') -----
+ finishedScrolling
+ self stopStepping.
+ self scrollBarAction: nil.
+ self class roundedScrollBarLook ifTrue:[
+ upButton borderStyle: (BorderStyle complexRaised width: upButton borderWidth).
+ downButton borderStyle: (BorderStyle complexRaised width: downButton borderWidth).
+ ] ifFalse:[
+ downButton borderStyle: BorderStyle thinGray.
+ upButton borderStyle: BorderStyle thinGray.
+ ].
+
+ !
Item was added:
+ ----- Method: ScrollBar>>hasButtons (in category 'testing') -----
+ hasButtons
+
+ ^ (self menuButton visible or: [upButton visible]) or: [downButton visible]!
Item was added:
+ ----- Method: ScrollBar>>initialize (in category 'initialize') -----
+ initialize
+
+ interval := 0.2.
+
+ super initialize.
+
+ scrollDelta := 0.02.
+ pageDelta := 0.2.
+
+ self color: Color transparent.
+
+ self class roundedScrollBarLook
+ ifFalse: [self borderWidth: 0]
+ ifTrue:[self borderStyle: ((BorderStyle complexFramed width: 2) "baseColor: Color gray")].!
Item was added:
+ ----- Method: ScrollBar>>initializeDownButton (in category 'initialize') -----
+ initializeDownButton
+ "initialize the receiver's downButton"
+
+ downButton := RectangleMorph
+ newBounds: self boundsForDownButton
+ color: self thumbColor.
+ downButton
+ on: #mouseDown
+ send: #scrollDownInit
+ to: self.
+ downButton
+ on: #mouseUp
+ send: #finishedScrolling
+ to: self.
+ self updateDownButtonImage.
+ self class roundedScrollBarLook
+ ifTrue:
+ [downButton color: Color veryLightGray.
+ downButton borderStyle: (BorderStyle complexRaised width: 3)]
+ ifFalse: [downButton setBorderWidth: 1 borderColor: Color lightGray].
+
+ self addMorph: downButton.
+ downButton visible: self class scrollBarsWithoutArrowButtons not.!
Item was added:
+ ----- Method: ScrollBar>>initializeEmbedded: (in category 'initialize') -----
+ initializeEmbedded: aBool
+ "aBool == true => inboard scrollbar
+ aBool == false => flop-out scrollbar"
+ self class roundedScrollBarLook ifFalse:[^self].
+ aBool ifTrue:[
+ self borderStyle: (BorderStyle inset width: 2).
+ self cornerStyle: #square.
+ ] ifFalse:[
+ self borderStyle: (BorderStyle width: 1 color: Color black).
+ self cornerStyle: #rounded.
+ ].
+ self removeAllMorphs.
+ self initializeSlider.!
Item was added:
+ ----- Method: ScrollBar>>initializeMenuButton (in category 'initialize') -----
+ initializeMenuButton
+ "initialize the receiver's menuButton"
+ "Preferences disable: #scrollBarsWithoutMenuButton"
+ "Preferences enable: #scrollBarsWithoutMenuButton"
+ menuButton := RectangleMorph
+ newBounds: self boundsForMenuButton
+ color: self thumbColor.
+ menuButton
+ on: #mouseEnter
+ send: #menuButtonMouseEnter:
+ to: self.
+ menuButton
+ on: #mouseDown
+ send: #menuButtonMouseDown:
+ to: self.
+ menuButton
+ on: #mouseLeave
+ send: #menuButtonMouseLeave:
+ to: self.
+ "menuButton
+ addMorphCentered: (RectangleMorph
+ newBounds: (0 @ 0 extent: 4 @ 2)
+ color: Color black)."
+ self updateMenuButtonImage.
+ self class roundedScrollBarLook
+ ifTrue: [menuButton color: Color veryLightGray.
+ menuButton
+ borderStyle: (BorderStyle complexRaised width: 3)]
+ ifFalse: [menuButton setBorderWidth: 1 borderColor: Color lightGray].
+
+ self addMorph: menuButton.
+ menuButton visible: (self class scrollBarsWithoutMenuButton or: [self bounds isWide]) not.!
Item was added:
+ ----- Method: ScrollBar>>initializePagingArea (in category 'initialize') -----
+ initializePagingArea
+
+ "Appearance"
+ pagingArea := RectangleMorph
+ newBounds: self totalSliderArea
+ color: (self class roundedScrollBarLook
+ ifTrue: [Color gray: 0.9]
+ ifFalse: [Color r: 0.6 g: 0.6 b: 0.8]).
+ Preferences gradientScrollBars
+ ifTrue: [pagingArea setBorderWidth: 1 borderColor: (Color lightGray alpha: 0.5)]
+ ifFalse: [pagingArea borderWidth: 0].
+ self addMorphBack: pagingArea.
+
+ "Interactions"
+ pagingArea
+ on: #mouseDown
+ send: #scrollPageInit:
+ to: self.
+ pagingArea
+ on: #mouseUp
+ send: #finishedScrolling
+ to: self.
+
+ !
Item was added:
+ ----- Method: ScrollBar>>initializeSlider (in category 'initialize') -----
+ initializeSlider
+
+ self
+ initializeMenuButton;
+ initializeUpButton;
+ initializeDownButton;
+ initializePagingArea.
+
+ super initializeSlider.
+ self expandSlider.
+
+ self class roundedScrollBarLook
+ ifTrue: [slider cornerStyle: #rounded.
+ slider
+ borderStyle: (BorderStyle complexRaised width: 3).
+ sliderShadow cornerStyle: #rounded].
+ self sliderColor: self sliderColor!
Item was added:
+ ----- Method: ScrollBar>>initializeUpButton (in category 'initialize') -----
+ initializeUpButton
+ "initialize the receiver's upButton"
+ upButton := RectangleMorph newBounds: self boundsForUpButton.
+ upButton color: self thumbColor.
+ upButton
+ on: #mouseDown
+ send: #scrollUpInit
+ to: self.
+ upButton
+ on: #mouseUp
+ send: #finishedScrolling
+ to: self.
+ self updateUpButtonImage.
+ self class roundedScrollBarLook
+ ifTrue: [upButton color: Color veryLightGray.
+ upButton
+ borderStyle: (BorderStyle complexRaised width: 3)]
+ ifFalse: [upButton setBorderWidth: 1 borderColor: Color lightGray].
+
+ self addMorph: upButton.
+ upButton visible: self class scrollBarsWithoutArrowButtons not.!
Item was added:
+ ----- Method: ScrollBar>>interval (in category 'access') -----
+ interval
+
+ ^ interval ifNil: [interval := 0.2]!
Item was added:
+ ----- Method: ScrollBar>>interval: (in category 'access') -----
+ interval: d
+ "Supply an optional floating fraction so slider can expand to indicate range"
+ interval := d min: 1.0.
+ self expandSlider.
+ self computeSlider.!
Item was added:
+ ----- Method: ScrollBar>>menuButton (in category 'access') -----
+ menuButton
+
+ ^ menuButton ifNil: [menuButton := RectangleMorph new]!
Item was added:
+ ----- Method: ScrollBar>>menuButtonMouseDown: (in category 'other events') -----
+ menuButtonMouseDown: event
+ event hand showTemporaryCursor: nil.
+ self use: menuSelector orMakeModelSelectorFor: 'MenuButtonPressed:'
+ in: [:sel | menuSelector := sel. model perform: sel with: event]!
Item was added:
+ ----- Method: ScrollBar>>menuImage (in category 'initialize') -----
+ menuImage
+ "answer a form to be used in the menu button"
+ ^ self class
+ boxOfSize: (self buttonExtent x min: self buttonExtent y)
+ color: self thumbColor!
Item was added:
+ ----- Method: ScrollBar>>menuSelector (in category 'access') -----
+ menuSelector
+ ^ menuSelector!
Item was added:
+ ----- Method: ScrollBar>>menuSelector: (in category 'access') -----
+ menuSelector: aSymbol
+ menuSelector := aSymbol.!
Item was added:
+ ----- Method: ScrollBar>>minExtent (in category 'geometry') -----
+ minExtent
+ "The minimum extent is that of 2 or 3 buttons in a row or column,
+ the 'up' and 'down' button and optionally the 'menu' button."
+
+ | btns cnt |
+ btns := 2.
+ self menuButton visible ifTrue: [
+ btns := btns + 1].
+ cnt := 1 at btns. "assume vertical layout"
+ self bounds isWide
+ ifTrue: [cnt := cnt transposed].
+ ^ upButton minExtent * cnt!
Item was added:
+ ----- Method: ScrollBar>>mouseDownInSlider: (in category 'other events') -----
+ mouseDownInSlider: event
+ self interval = self maximumValue ifTrue:
+ ["make the entire scrollable area visible if a full scrollbar is clicked on"
+ self setValue: 0.
+ self model hideOrShowScrollBars.].
+ " super mouseDownInSlider: event"
+ !
Item was added:
+ ----- Method: ScrollBar>>pagingArea (in category 'access') -----
+ pagingArea
+ ^pagingArea!
Item was added:
+ ----- Method: ScrollBar>>resetTimer (in category 'scroll timing') -----
+ resetTimer
+ timeOfMouseDown := Time millisecondClockValue.
+ timeOfLastScroll := timeOfMouseDown - 1000 max: 0.
+ nextPageDirection := nil.
+ currentScrollDelay := nil!
Item was added:
+ ----- Method: ScrollBar>>scrollBarAction (in category 'scrolling') -----
+ scrollBarAction
+ ^self valueOfProperty: #scrollBarAction!
Item was added:
+ ----- Method: ScrollBar>>scrollBarAction: (in category 'scrolling') -----
+ scrollBarAction: aSymbol
+ self setProperty: #scrollBarAction toValue: aSymbol!
Item was added:
+ ----- Method: ScrollBar>>scrollDelta (in category 'access') -----
+ scrollDelta
+ ^ scrollDelta!
Item was added:
+ ----- Method: ScrollBar>>scrollDelta:pageDelta: (in category 'access') -----
+ scrollDelta: d1 pageDelta: d2
+ "Supply optional increments for better scrolling of, eg, text"
+ scrollDelta := d1.
+ pageDelta := d2.!
Item was added:
+ ----- Method: ScrollBar>>scrollDown (in category 'scrolling') -----
+ scrollDown
+ self flag: #obsolete.
+ downButton eventHandler: nil.
+ downButton on: #mouseDown send: #scrollDownInit to: self.
+ downButton on: #mouseUp send: #finishedScrolling to: self.
+ ^self scrollDownInit!
Item was added:
+ ----- Method: ScrollBar>>scrollDown: (in category 'scrolling') -----
+ scrollDown: count
+ self setValue: value + (scrollDelta * count).!
Item was added:
+ ----- Method: ScrollBar>>scrollDownInit (in category 'scrolling') -----
+ scrollDownInit
+ downButton borderInset.
+ self resetTimer.
+ self scrollBarAction: #doScrollDown.
+ self startStepping.!
Item was added:
+ ----- Method: ScrollBar>>scrollPageInit: (in category 'scrolling') -----
+ scrollPageInit: evt
+ self resetTimer.
+ self setNextDirectionFromEvent: evt.
+ self scrollBarAction: #doScrollByPage.
+ self startStepping.!
Item was added:
+ ----- Method: ScrollBar>>scrollUp (in category 'scrolling') -----
+ scrollUp
+ self flag: #obsolete.
+ upButton eventHandler: nil.
+ upButton on: #mouseDown send: #scrollUpInit to: self.
+ upButton on: #mouseUp send: #finishedScrolling to: self.
+ ^self scrollUpInit!
Item was added:
+ ----- Method: ScrollBar>>scrollUp: (in category 'scrolling') -----
+ scrollUp: count
+ self setValue: value - (scrollDelta * count).!
Item was added:
+ ----- Method: ScrollBar>>scrollUpInit (in category 'scrolling') -----
+ scrollUpInit
+ upButton borderInset.
+ self resetTimer.
+ self scrollBarAction: #doScrollUp.
+ self startStepping.!
Item was added:
+ ----- Method: ScrollBar>>setNextDirectionFromEvent: (in category 'scrolling') -----
+ setNextDirectionFromEvent: event
+
+ nextPageDirection := bounds isWide ifTrue: [
+ event cursorPoint x >= slider center x
+ ]
+ ifFalse: [
+ event cursorPoint y >= slider center y
+ ]
+
+ !
Item was added:
+ ----- Method: ScrollBar>>sliderColor: (in category 'access') -----
+ sliderColor: aColor
+ "Change the color of the scrollbar to go with aColor."
+ | buttonColor |
+ super sliderColor: aColor.
+ self updateSliderColor: aColor.
+ buttonColor := self thumbColor.
+ self menuButton color: buttonColor.
+ upButton color: buttonColor.
+ downButton color: buttonColor.
+
+ self class updateScrollBarButtonsAspect: {self menuButton. upButton. downButton} color: buttonColor.
+
+ self updateMenuButtonImage.
+ self updateUpButtonImage.
+ self updateDownButtonImage.!
Item was added:
+ ----- Method: ScrollBar>>sliderExtent (in category 'geometry') -----
+ sliderExtent
+ "The sliderExtent is now stored in the slider itself, not hardcoded as it is in the superclass."
+ ^slider extent!
Item was added:
+ ----- Method: ScrollBar>>sliderShadowColor (in category 'access') -----
+ sliderShadowColor
+ ^ self class roundedScrollBarLook
+ ifTrue: [self sliderColor darker]
+ ifFalse: [super sliderShadowColor]
+ !
Item was added:
+ ----- Method: ScrollBar>>sliderThickness (in category 'geometry') -----
+ sliderThickness
+ ^ self width min: self height!
Item was added:
+ ----- Method: ScrollBar>>step (in category 'stepping and presenter') -----
+ step
+ | action |
+ action := self scrollBarAction.
+ action ifNotNil:[self perform: action].!
Item was added:
+ ----- Method: ScrollBar>>stepTime (in category 'testing') -----
+ stepTime
+ ^ currentScrollDelay ifNil: [300]!
Item was added:
+ ----- Method: ScrollBar>>thumbColor (in category 'access') -----
+ thumbColor
+ "Problem: Part of the ScrollBar/Slider code uses 'slider' to mean the entire scrollbar/slider widget, and part of it uses 'slider' to mean only the draggable 'thumb'. This should be cleaned up so that 'thumb' is used instead of 'slider' where appropriate. For now, the meaning of thumbColor is clear, at least."
+
+ ^ self sliderColor alphaMixed: 0.5 with: (Color gray: 0.95)
+ !
Item was added:
+ ----- Method: ScrollBar>>totalSliderArea (in category 'geometry') -----
+ totalSliderArea
+ | upperReferenceBounds lowerReferenceBounds |
+ upperReferenceBounds := (upButton visible ifFalse: [self menuButton visible ifTrue: [self menuButton] ifFalse: [nil]] ifTrue: [upButton])
+ ifNil: [self topLeft corner: (bounds isWide ifTrue: [self bottomLeft + (1 at 0)] ifFalse: [self topRight + (0 at 1)])]
+ ifNotNil: [:button | button bounds].
+ lowerReferenceBounds := downButton visible
+ ifFalse: [(bounds isWide ifTrue: [self topRight - (1 at 0)] ifFalse: [self bottomLeft - (0 at 1)]) corner: self bottomRight]
+ ifTrue: [downButton bounds].
+ ^ bounds isWide
+ ifTrue: [upperReferenceBounds topRight - (1 at 0) corner: lowerReferenceBounds bottomLeft + (1 at 0)]
+ ifFalse:[upperReferenceBounds bottomLeft - (0 at 1) corner: lowerReferenceBounds topRight + (0 at 1)].
+ !
Item was added:
+ ----- Method: ScrollBar>>upArrow8Bit (in category 'initialize') -----
+ upArrow8Bit
+
+ "convert to 8-bit and convert white to transparent to avoid gratuitous conversion every time we put one in an ImageMorph"
+
+ ^UpArrow8Bit ifNil: [
+ UpArrow8Bit := (ColorForm mappingWhiteToTransparentFrom: UpArrow) asFormOfDepth: 8
+ ]!
Item was added:
+ ----- Method: ScrollBar>>upImage (in category 'initialize') -----
+ upImage
+ "answer a form to be used in the up button"
+ ^ self class
+ arrowOfDirection: (bounds isWide
+ ifTrue: [#left]
+ ifFalse: [#top])
+ size: (self buttonExtent x min: self buttonExtent y)
+ color: self thumbColor!
Item was added:
+ ----- Method: ScrollBar>>updateDownButtonImage (in category 'initialize') -----
+ updateDownButtonImage
+ "update the receiver's downButton. put a new image inside"
+ downButton removeAllMorphs.
+ downButton
+ addMorphCentered: (ImageMorph new image: self downImage)!
Item was added:
+ ----- Method: ScrollBar>>updateMenuButtonImage (in category 'initialize') -----
+ updateMenuButtonImage
+ "update the receiver's menuButton. put a new image inside"
+
+ self menuButton removeAllMorphs.
+ self menuButton addMorphCentered: (ImageMorph new image: self menuImage).!
Item was added:
+ ----- Method: ScrollBar>>updateSlider (in category 'initialize') -----
+ updateSlider
+
+ | imagesNeedUpdate |
+ imagesNeedUpdate := upButton width ~= (self bounds isWide ifTrue: [self height] ifFalse: [self width]).
+
+ self menuButton
+ visible: (self bounds isWide or: [self class scrollBarsWithoutMenuButton]) not;
+ bounds: self boundsForMenuButton.
+ upButton
+ visible: self class scrollBarsWithoutArrowButtons not;
+ bounds: self boundsForUpButton.
+ downButton
+ visible: self class scrollBarsWithoutArrowButtons not;
+ bounds: self boundsForDownButton.
+
+ super updateSlider.
+
+ pagingArea bounds: self totalSliderArea.
+ self expandSlider.
+
+ imagesNeedUpdate ifTrue: [
+ self menuButton visible ifTrue: [self updateMenuButtonImage].
+ upButton visible ifTrue: [self updateUpButtonImage].
+ downButton visible ifTrue: [self updateDownButtonImage]].!
Item was added:
+ ----- Method: ScrollBar>>updateSliderColor: (in category 'access') -----
+ updateSliderColor: aColor
+
+ | gradient |
+ Preferences gradientScrollBars ifFalse: [
+ slider
+ borderColor: (aColor adjustBrightness: -0.3);
+ color: aColor.
+ pagingArea
+ borderColor: (aColor muchDarker alpha: pagingArea borderStyle color alpha);
+ color: (aColor darker alpha: 0.35).
+ ^ self].
+
+ slider borderStyle: (BorderStyle width: 1 color: Color lightGray).
+
+ "Fill the slider."
+ gradient := GradientFillStyle ramp: {
+ 0 -> (Color gray: 0.95).
+ 0.49 -> (Color gray: 0.9).
+ 0.5 -> (Color gray: 0.87).
+ 1 -> (Color gray: 0.93).
+ }.
+ gradient origin: slider topLeft.
+ gradient direction: (self bounds isWide
+ ifTrue:[0 at slider height]
+ ifFalse:[slider width at 0]).
+ slider fillStyle: gradient.
+
+ "Fill the paging area."
+ gradient := GradientFillStyle ramp: {
+ 0 -> (Color gray: 0.65).
+ 0.6 -> (Color gray: 0.82).
+ 1 -> (Color gray: 0.88).
+ }.
+ gradient origin: self topLeft.
+ gradient direction: (self bounds isWide
+ ifTrue:[0 at self height]
+ ifFalse:[self width at 0]).
+ pagingArea fillStyle: gradient.!
Item was added:
+ ----- Method: ScrollBar>>updateUpButtonImage (in category 'initialize') -----
+ updateUpButtonImage
+ "update the receiver's upButton. put a new image inside"
+ upButton removeAllMorphs.
+ upButton
+ addMorphCentered: (ImageMorph new image: self upImage)!
Item was added:
+ ----- Method: ScrollBar>>waitForDelay1:delay2: (in category 'scroll timing') -----
+ waitForDelay1: delay1 delay2: delay2
+ "Return true if an appropriate delay has passed since the last scroll operation.
+ The delay decreases exponentially from delay1 to delay2."
+
+ | now scrollDelay |
+ timeOfLastScroll ifNil: [self resetTimer]. "Only needed for old instances"
+ now := Time millisecondClockValue.
+ (scrollDelay := currentScrollDelay) isNil
+ ifTrue: [scrollDelay := delay1 "initial delay"].
+ currentScrollDelay := scrollDelay * 9 // 10 max: delay2. "decrease the delay"
+ timeOfLastScroll := now.
+ ^true!
Item was added:
+ ----- Method: ScrollBar>>wantsSteps (in category 'testing') -----
+ wantsSteps
+ ^self scrollBarAction notNil!
Item was added:
+ MorphicModel subclass: #ScrollPane
+ instanceVariableNames: 'scrollBar scroller retractableScrollBar scrollBarOnLeft getMenuSelector getMenuTitleSelector scrollBarHidden hasFocus hScrollBar lockOffset'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !ScrollPane commentStamp: 'mk 8/9/2005 10:34' prior: 0!
+ The scroller (a transform) of a scrollPane is driven by the scrollBar. The scroll values vary from 0.0, meaning zero offset to 1.0 meaning sufficient offset such that the bottom of the scrollable material appears 3/4 of the way down the pane. The total distance to achieve this range is called the totalScrollRange.
+
+ Basic clue about utilization of the ScrollPane class is given in:
+ ScrollPane example1.
+ ScrollPane example2.!
Item was added:
+ ----- Method: ScrollPane class>>example1 (in category 'examples') -----
+ example1
+ | window scrollPane pasteUpMorph |
+ window := SystemWindow new.
+ scrollPane := ScrollPane new.
+ pasteUpMorph := PasteUpMorph new.
+ pasteUpMorph extent: 1000 at 1000.
+ scrollPane scroller addMorph: pasteUpMorph.
+ window addMorph: scrollPane frame: (0 at 0 corner: 1 at 1).
+ window openInWorld.!
Item was added:
+ ----- Method: ScrollPane class>>example2 (in category 'examples') -----
+ example2
+ | window scrollPane pasteUpMorph point textMorph |
+ window := SystemWindow new.
+ scrollPane := ScrollPane new.
+ pasteUpMorph := PasteUpMorph new.
+ pasteUpMorph extent: 1000 at 1000.
+ scrollPane scroller addMorph: pasteUpMorph.
+ window addMorph: scrollPane frame: (0 at 0 corner: 1 at 1).
+ 0 to: 1000 by: 100 do:
+ [:x | 0 to: 1000 by: 100 do:
+ [:y |
+ point := x at y.
+ textMorph := TextMorph new contents: point asString.
+ textMorph position: point.
+ pasteUpMorph addMorph: textMorph
+ ]
+ ].
+ window openInWorld.!
Item was added:
+ ----- Method: ScrollPane class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ "OK to instantiate"
+ ^ true!
Item was added:
+ ----- Method: ScrollPane>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ retractableScrollBar
+ ifTrue: [aCustomMenu add: 'make scrollbar inboard' translated action: #retractableOrNot]
+ ifFalse: [aCustomMenu add: 'make scrollbar retractable' translated action: #retractableOrNot].
+ scrollBarOnLeft
+ ifTrue: [aCustomMenu add: 'scroll bar on right' translated action: #leftOrRight]
+ ifFalse: [aCustomMenu add: 'scroll bar on left' translated action: #leftOrRight]!
Item was added:
+ ----- Method: ScrollPane>>adoptPaneColor: (in category 'access') -----
+ adoptPaneColor: paneColor
+ super adoptPaneColor: paneColor.
+
+ "May not be in the hierarchy at the moment."
+ scrollBar adoptPaneColor: paneColor.
+ hScrollBar adoptPaneColor: paneColor.
+
+ paneColor ifNotNil: [:c | self borderColor: (c adjustBrightness: -0.3)].!
Item was added:
+ ----- Method: ScrollPane>>alwaysShowHScrollBar: (in category 'access options') -----
+ alwaysShowHScrollBar: bool
+ self setProperty: #hScrollBarAlways toValue: bool.
+ self hHideOrShowScrollBar.
+ !
Item was added:
+ ----- Method: ScrollPane>>alwaysShowScrollBars: (in category 'access options') -----
+ alwaysShowScrollBars: bool
+ "Get rid of scroll bar for short panes that don't want it shown."
+
+ self
+ alwaysShowHScrollBar: bool;
+ alwaysShowVScrollBar: bool.
+ !
Item was added:
+ ----- Method: ScrollPane>>alwaysShowVScrollBar: (in category 'access options') -----
+ alwaysShowVScrollBar: bool
+
+ self setProperty: #vScrollBarAlways toValue: bool.
+ self vHideOrShowScrollBar.
+ !
Item was added:
+ ----- Method: ScrollPane>>borderStyle: (in category 'accessing') -----
+ borderStyle: aBorderStyle
+ super borderStyle: aBorderStyle.
+ self setScrollDeltas!
Item was added:
+ ----- Method: ScrollPane>>borderWidth: (in category 'accessing') -----
+ borderWidth: aNumber
+ super borderWidth: aNumber.
+ self setScrollDeltas!
Item was added:
+ ----- Method: ScrollPane>>canBeEncroached (in category 'testing') -----
+ canBeEncroached
+ "For support of the smartHorizontalSplitters preference."
+ ^ scrollBar isInWorld not!
Item was added:
+ ----- Method: ScrollPane>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+
+ (super containsPoint: aPoint) ifTrue: [^ true].
+
+ "Also include v scrollbar when it is extended..."
+ ((retractableScrollBar and: [submorphs includes: scrollBar]) and:
+ [scrollBar containsPoint: aPoint])
+ ifTrue:[ ^true ].
+
+ "Also include hScrollbar when it is extended..."
+ ^(retractableScrollBar and: [self hIsScrollbarShowing]) and:
+ [hScrollBar containsPoint: aPoint]
+ !
Item was added:
+ ----- Method: ScrollPane>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ Color black!
Item was added:
+ ----- Method: ScrollPane>>defaultExtent (in category 'initialization') -----
+ defaultExtent
+ ^150 at 120
+ !
Item was added:
+ ----- Method: ScrollPane>>extent: (in category 'geometry') -----
+ extent: newExtent
+
+ | oldW oldH wasHShowing wasVShowing noVPlease noHPlease minH minW |
+
+ oldW := self width.
+ oldH := self height.
+ wasHShowing := self hIsScrollbarShowing.
+ wasVShowing := self vIsScrollbarShowing.
+
+ "Figure out the minimum width and height for this pane so that scrollbars will appear"
+ noVPlease := self valueOfProperty: #noVScrollBarPlease ifAbsent: [false].
+ noHPlease := self valueOfProperty: #noHScrollBarPlease ifAbsent: [false].
+ minH := self scrollBarThickness + 16.
+ minW := self scrollBarThickness + 20.
+ noVPlease ifTrue:[
+ noHPlease
+ ifTrue:[minH := 1. minW := 1 ]
+ ifFalse:[minH := self scrollBarThickness ].
+ ] ifFalse:[
+ noHPlease
+ ifTrue:[minH := self scrollBarThickness + 5].
+ ].
+ super extent: (newExtent max: (minW at minH)).
+
+ "Now reset widget sizes"
+ self resizeScrollBars; resizeScroller; hideOrShowScrollBars.
+
+ "Now resetScrollDeltas where appropriate, first the vScrollBar..."
+ ((self height ~~ oldH) or: [ wasHShowing ~~ self hIsScrollbarShowing]) ifTrue:
+ [(retractableScrollBar or: [ self vIsScrollbarShowing ]) ifTrue:
+ [ self vSetScrollDelta ]].
+
+ "...then the hScrollBar"
+ ((self width ~~ oldW) or: [wasVShowing ~~ self vIsScrollbarShowing]) ifTrue:
+ [(retractableScrollBar or: [ self hIsScrollbarShowing ]) ifTrue:
+ [ self hSetScrollDelta ]].
+
+ !
Item was added:
+ ----- Method: ScrollPane>>flatColoredScrollBarLook (in category 'access') -----
+ flatColoredScrollBarLook
+ "Currently only show the flat (not rounded) + colored-to-match-window scrollbar look when inboard."
+ ^ retractableScrollBar not or: [ScrollBar alwaysShowFlatScrollbarForAlternativeLook]
+ !
Item was added:
+ ----- Method: ScrollPane>>getMenu: (in category 'menu') -----
+ getMenu: shiftKeyState
+ "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."
+ | menu aMenu aTitle |
+ getMenuSelector == nil ifTrue: [^ nil].
+ menu := MenuMorph new defaultTarget: model.
+ aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
+ getMenuSelector numArgs = 1 ifTrue:
+ [aMenu := model perform: getMenuSelector with: menu.
+ aTitle ifNotNil: [aMenu addTitle: aTitle].
+ ^ aMenu].
+ getMenuSelector numArgs = 2 ifTrue:
+ [aMenu := model perform: getMenuSelector with: menu with: shiftKeyState.
+ aTitle ifNotNil: [aMenu addTitle: aTitle].
+ ^ aMenu].
+ ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'!
Item was added:
+ ----- Method: ScrollPane>>hExtraScrollRange (in category 'geometry') -----
+ hExtraScrollRange
+ "Return the amount of extra blank space to include below the bottom of the scroll content."
+ ^ 0
+ !
Item was added:
+ ----- Method: ScrollPane>>hHideOrShowScrollBar (in category 'scrolling') -----
+ hHideOrShowScrollBar
+ "Hide or show the scrollbar depending on if the pane is scrolled/scrollable."
+
+ self hIsScrollbarNeeded
+ ifTrue:[ self hShowScrollBar ]
+ ifFalse: [ self hHideScrollBar ].
+ !
Item was added:
+ ----- Method: ScrollPane>>hHideScrollBar (in category 'scrolling') -----
+ hHideScrollBar
+
+ self hIsScrollbarShowing ifFalse: [^self].
+ self removeMorph: hScrollBar.
+ retractableScrollBar ifFalse: [self resetExtent].
+
+ !
Item was added:
+ ----- Method: ScrollPane>>hInitScrollBarTEMPORARY (in category 'initialization') -----
+ hInitScrollBarTEMPORARY
+ "This is called lazily before the hScrollBar is accessed in a couple of places. It is provided to transition old ScrollPanes lying around that do not have an hScrollBar. Once it has been in the image for awhile, and all ScrollPanes have an hScrollBar, this method and it's references can be removed. "
+
+ "Temporary method for filein of changeset"
+ hScrollBar ifNil:
+ [hScrollBar := ScrollBar new model: self slotName: 'hScrollBar'.
+ hScrollBar borderWidth: 1; borderColor: Color black.
+ self
+ resizeScrollBars;
+ setScrollDeltas;
+ hideOrShowScrollBars].
+ !
Item was added:
+ ----- Method: ScrollPane>>hIsScrollable (in category 'geometry testing') -----
+ hIsScrollable
+ "If the contents of the pane are too small to scroll, return false."
+
+ ^ self hLeftoverScrollRange > 0
+ !
Item was added:
+ ----- Method: ScrollPane>>hIsScrollbarNeeded (in category 'scrolling') -----
+ hIsScrollbarNeeded
+ "Return whether the horz scrollbar is needed"
+
+ "Don't do anything with the retractable scrollbar unless we have focus"
+ retractableScrollBar & self hasFocus not ifTrue: [^false].
+
+ "Don't show it if we were told not to."
+ (self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]) ifTrue: [^false].
+
+ "Always show it if we were told to"
+ (self valueOfProperty: #hScrollBarAlways ifAbsent: [false]) ifTrue: [^true].
+
+ ^self hIsScrollable
+ !
Item was added:
+ ----- Method: ScrollPane>>hIsScrollbarShowing (in category 'geometry testing') -----
+ hIsScrollbarShowing
+ "Return true if a horz scroll bar is currently showing"
+
+ ^submorphs includes: hScrollBar
+ !
Item was added:
+ ----- Method: ScrollPane>>hIsScrolled (in category 'geometry testing') -----
+ hIsScrolled
+ "If the scroller is not set to x = 0, then the pane has been h-scrolled."
+ ^scroller offset x > 0
+ !
Item was added:
+ ----- Method: ScrollPane>>hLeftoverScrollRange (in category 'geometry') -----
+ hLeftoverScrollRange
+ "Return the entire scrolling range minus the currently viewed area."
+
+ ^ scroller hasSubmorphs
+ ifFalse: [0]
+ ifTrue: [self hTotalScrollRange - scroller width max: 0]
+ !
Item was added:
+ ----- Method: ScrollPane>>hMargin (in category 'access') -----
+ hMargin
+ "pixels of whitespace at to the left of the scroller when the hScrollBar offset is 0"
+ ^0
+ !
Item was added:
+ ----- Method: ScrollPane>>hResizeScrollBar (in category 'geometry') -----
+ hResizeScrollBar
+
+ | topLeft h border offset |
+
+ "TEMPORARY: IF OLD SCROLLPANES LYING AROUND THAT DON'T HAVE A hScrollBar, INIT THEM"
+ hScrollBar ifNil: [ self hInitScrollBarTEMPORARY].
+
+ (self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]) ifTrue: [^self].
+ bounds ifNil: [ self fullBounds ].
+
+ h := self scrollBarThickness.
+ border := borderWidth.
+ offset := (scrollBarOnLeft and: [self vIsScrollbarShowing])
+ ifTrue: [h]
+ ifFalse: [0].
+
+ topLeft := retractableScrollBar
+ ifTrue: [bounds bottomLeft + (border + offset @ border negated)]
+ ifFalse: [bounds bottomLeft + (border + offset @ (h + border) negated)].
+
+ hScrollBar bounds: (topLeft + (border negated @ border) extent: self hScrollBarWidth@ h)
+ !
Item was added:
+ ----- Method: ScrollPane>>hScrollBar (in category 'access') -----
+ hScrollBar
+ ^ hScrollBar!
Item was added:
+ ----- Method: ScrollPane>>hScrollBarMenuButtonPressed: (in category 'scroll bar events') -----
+ hScrollBarMenuButtonPressed: event
+ ^ self scrollBarMenuButtonPressed: event
+ !
Item was added:
+ ----- Method: ScrollPane>>hScrollBarValue: (in category 'scrolling') -----
+ hScrollBarValue: scrollValue
+
+ scroller hasSubmorphs ifFalse: [^ self].
+ lockOffset == true ifFalse: [
+ scroller offset: scrollValue @scroller offset y].
+ !
Item was added:
+ ----- Method: ScrollPane>>hScrollBarWidth (in category 'geometry') -----
+ hScrollBarWidth
+ "Return the width of the horizontal scrollbar"
+
+
+ | w |
+
+ w := bounds width "- (2 * borderWidth)".
+
+ (retractableScrollBar not and: [self vIsScrollbarNeeded])
+ ifTrue: [w := w - self scrollBarThickness ].
+
+ ^w
+ !
Item was added:
+ ----- Method: ScrollPane>>hSetScrollDelta (in category 'geometry') -----
+ hSetScrollDelta
+ "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."
+
+ | delta |
+ delta := self scrollDeltaWidth.
+
+ hScrollBar
+ truncate: true;
+ scrollDelta: delta
+ pageDelta: 10*delta;
+ maximumValue: self hLeftoverScrollRange;
+ interval: (self hTotalScrollRange = 0
+ ifTrue: [1.0]
+ ifFalse: [scroller width / self hTotalScrollRange]);
+ setValue: scroller offset x.!
Item was added:
+ ----- Method: ScrollPane>>hShowScrollBar (in category 'scrolling') -----
+ hShowScrollBar
+
+ self hIsScrollbarShowing ifTrue: [^self].
+ self hResizeScrollBar.
+ self privateAddMorph: hScrollBar atIndex: 1.
+ retractableScrollBar ifFalse: [self resetExtent].
+ !
Item was added:
+ ----- Method: ScrollPane>>hTotalScrollRange (in category 'geometry') -----
+ hTotalScrollRange
+ "Return the entire scrolling range."
+ ^ self hUnadjustedScrollRange + self hExtraScrollRange + self hMargin
+ !
Item was added:
+ ----- Method: ScrollPane>>hUnadjustedScrollRange (in category 'geometry') -----
+ hUnadjustedScrollRange
+ "Return the width extent of the receiver's submorphs."
+
+ | submorphBounds |
+ submorphBounds := scroller localSubmorphBounds ifNil: [^ 0].
+ ^ submorphBounds right
+ !
Item was added:
+ ----- Method: ScrollPane>>handlesKeyboard: (in category 'event handling') -----
+ handlesKeyboard: evt
+ ^ true!
Item was added:
+ ----- Method: ScrollPane>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ ^ true
+ !
Item was added:
+ ----- Method: ScrollPane>>handlesMouseOver: (in category 'event handling') -----
+ handlesMouseOver: evt
+ "Could just ^ true, but this ensures that scroll bars won't flop out
+ if you mouse-over appendages such as connecting pins."
+ self flag: #arNote. "I have no idea how the code below could've ever worked. If the receiver does not handle mouse over events then it should not receive any #mouseLeave if the mouse leaves the receiver for real. This is because 'evt cursorPoint' describes the *end* point of the movement and considering that the code would return false if the move ends outside the receiver the scroll bars should never pop back in again. Which is exactly what happens with the new event logic if you don't just ^true. I'm leaving the code in for reference - perhaps somebody can make sense from it; I sure cannot."
+ ^true
+ "
+ | cp |
+ cp := evt cursorPoint.
+ (bounds containsPoint: cp)
+ ifTrue: [^ true]
+ ifFalse: [self submorphsDo:
+ [:m | (m containsPoint: cp) ifTrue:
+ [m == scrollBar
+ ifTrue: [^ true]
+ ifFalse: [^ false]]].
+ ^ false]
+ "!
Item was added:
+ ----- Method: ScrollPane>>hasFocus (in category 'access') -----
+ hasFocus
+ "hasFocus is currently set by mouse enter/leave events.
+ This inst var should probably be moved up to a higher superclass."
+
+ ^ hasFocus ifNil: [false]!
Item was added:
+ ----- Method: ScrollPane>>hideHScrollBarIndefinitely: (in category 'access options') -----
+ hideHScrollBarIndefinitely: bool
+ "Get rid of scroll bar for short panes that don't want it shown."
+
+ self setProperty: #noHScrollBarPlease toValue: bool.
+ self hHideOrShowScrollBar.
+ !
Item was added:
+ ----- Method: ScrollPane>>hideOrShowScrollBar (in category 'scrolling') -----
+ hideOrShowScrollBar
+ "Hide or show the scrollbar depending on if the pane is scrolled/scrollable."
+
+ "Don't do anything with the retractable scrollbar unless we have focus"
+ retractableScrollBar & self hasFocus not ifTrue: [^self].
+ "Don't show it if we were told not to."
+ (self valueOfProperty: #noScrollBarPlease ifAbsent: [false]) ifTrue: [^self].
+
+ self vIsScrollable not & self isScrolledFromTop not ifTrue: [self vHideScrollBar].
+ self vIsScrollable | self isScrolledFromTop ifTrue: [self vShowScrollBar].
+ !
Item was added:
+ ----- Method: ScrollPane>>hideOrShowScrollBars (in category 'scrolling') -----
+ hideOrShowScrollBars
+
+ | wasHShowing wasVShowing |
+
+ wasVShowing := self vIsScrollbarShowing.
+ wasHShowing := self hIsScrollbarShowing.
+
+ self
+ vHideOrShowScrollBar;
+ hHideOrShowScrollBar;
+ resizeScrollBars.
+
+ (wasVShowing and: [self vIsScrollbarShowing not]) ifTrue:
+ ["Make sure the delta is 0"
+ (scroller offset y = 0)
+ ifFalse:[ scroller offset: (scroller offset x at 0) ]].
+
+ (wasHShowing and: [self hIsScrollbarShowing not]) ifTrue:
+ [(scroller offset x <= 0)
+ ifFalse:[ scroller offset: (self hMargin negated at scroller offset y)]].
+ !
Item was added:
+ ----- Method: ScrollPane>>hideScrollBars (in category 'scrolling') -----
+ hideScrollBars
+ self
+ vHideScrollBar;
+ hHideScrollBar
+ !
Item was added:
+ ----- Method: ScrollPane>>hideScrollBarsIndefinitely (in category 'access options') -----
+ hideScrollBarsIndefinitely
+ self hideScrollBarsIndefinitely: true
+ !
Item was added:
+ ----- Method: ScrollPane>>hideScrollBarsIndefinitely: (in category 'access options') -----
+ hideScrollBarsIndefinitely: bool
+ "Get rid of scroll bar for short panes that don't want it shown."
+
+ self hideVScrollBarIndefinitely: bool.
+ self hideHScrollBarIndefinitely: bool.
+ !
Item was added:
+ ----- Method: ScrollPane>>hideVScrollBarIndefinitely: (in category 'access options') -----
+ hideVScrollBarIndefinitely: bool
+ "Get rid of scroll bar for short panes that don't want it shown."
+
+ self setProperty: #noVScrollBarPlease toValue: bool.
+ self vHideOrShowScrollBar.
+ !
Item was added:
+ ----- Method: ScrollPane>>initialize (in category 'initialization') -----
+ initialize
+
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ self initializePreferences.
+ hasFocus := false.
+ self initializeScrollBars.
+ ""
+ self extent: self defaultExtent.
+ self hideOrShowScrollBars.
+
+
+ !
Item was added:
+ ----- Method: ScrollPane>>initializePreferences (in category 'initialization') -----
+ initializePreferences
+ "initialize the receiver's Preferences"
+ retractableScrollBar := false.
+ scrollBarOnLeft := (Preferences valueOfFlag: #scrollBarsOnRight) not.
+
+
+ !
Item was added:
+ ----- Method: ScrollPane>>initializeScrollBars (in category 'initialization') -----
+ initializeScrollBars
+ "initialize the receiver's scrollBar"
+
+ (scrollBar := ScrollBar on: self getValue: nil setValue: #vScrollBarValue:)
+ menuSelector: #vScrollBarMenuButtonPressed:.
+ (hScrollBar := ScrollBar on: self getValue: nil setValue: #hScrollBarValue:)
+ menuSelector: #hScrollBarMenuButtonPressed:.
+
+ ""
+ scroller := TransformMorph new color: Color transparent.
+ scroller offset: 0 @ 0.
+ self addMorph: scroller.
+ ""
+ scrollBar initializeEmbedded: retractableScrollBar not.
+ hScrollBar initializeEmbedded: retractableScrollBar not.
+ retractableScrollBar ifFalse:
+ [self
+ addMorph: scrollBar;
+ addMorph: hScrollBar].
+
+ Preferences alwaysShowVScrollbar ifTrue:
+ [ self alwaysShowVScrollBar: true ].
+
+ Preferences alwaysHideHScrollbar
+ ifTrue:[self hideHScrollBarIndefinitely: true ]
+ ifFalse:
+ [Preferences alwaysShowHScrollbar ifTrue:
+ [ self alwaysShowHScrollBar: true ]].
+ !
Item was added:
+ ----- Method: ScrollPane>>innerBounds (in category 'geometry') -----
+ innerBounds
+ | inner |
+ inner := super innerBounds.
+ retractableScrollBar | (submorphs includes: scrollBar) not ifFalse:[
+ inner := (scrollBarOnLeft
+ ifTrue: [scrollBar right @ inner top corner: inner bottomRight]
+ ifFalse: [inner topLeft corner: scrollBar left @ inner bottom])
+ ].
+ (retractableScrollBar | self hIsScrollbarShowing not)
+ ifTrue: [^ inner]
+ ifFalse: [^ inner topLeft corner: (inner bottomRight - (0@(self scrollBarThickness - self borderWidth)))].
+ !
Item was added:
+ ----- Method: ScrollPane>>isAScrollbarShowing (in category 'geometry testing') -----
+ isAScrollbarShowing
+ "Return true if a either retractable scroll bar is currently showing"
+ retractableScrollBar ifFalse:[^true].
+ ^self hIsScrollbarShowing or: [self vIsScrollbarShowing]
+ !
Item was added:
+ ----- Method: ScrollPane>>isScrolledFromTop (in category 'geometry testing') -----
+ isScrolledFromTop
+ "Have the contents of the pane been scrolled, so that the top of the contents are not visible?"
+ ^scroller offset y > 0
+ !
Item was added:
+ ----- Method: ScrollPane>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+ "If pane is not empty, pass the event to the last submorph,
+ assuming it is the most appropriate recipient (!!)"
+
+ (self scrollByKeyboard: evt) ifTrue: [^self].
+ scroller submorphs last keyStroke: evt!
Item was added:
+ ----- Method: ScrollPane>>leftOrRight (in category 'menu') -----
+ leftOrRight "Change scroll bar location"
+ scrollBarOnLeft := scrollBarOnLeft not.
+ self extent: self extent!
Item was added:
+ ----- Method: ScrollPane>>menuTitleSelector: (in category 'menu') -----
+ menuTitleSelector: aSelector
+ getMenuTitleSelector := aSelector!
Item was added:
+ ----- Method: ScrollPane>>minExtent (in category 'geometry') -----
+ minExtent
+ "Answer the calculated minimum size of the receiver."
+
+ ^ super minExtent max: self minScrollbarExtent!
Item was added:
+ ----- Method: ScrollPane>>minScrollbarExtent (in category 'geometry') -----
+ minScrollbarExtent
+ "Answer the minimum extent occupied by the receiver..
+ It is assumed the if the receiver is sized to its minimum both scrollbars will be used (and visible) unless they have been turned off explicitly.
+ This makes the behaviour also more predictable."
+ ^((self valueOfProperty: #noVScrollBarPlease ifAbsent: [false])
+ ifTrue:[0 at 0] ifFalse:[scrollBar minExtent]) +
+ ((self valueOfProperty: #noHScrollBarPlease ifAbsent: [false])
+ ifTrue:[0 at 0] ifFalse:[hScrollBar minExtent])!
Item was added:
+ ----- Method: ScrollPane>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ evt yellowButtonPressed "First check for option (menu) click"
+ ifTrue: [^ self yellowButtonActivity: evt shiftPressed].
+ "If pane is not empty, pass the event to the last submorph,
+ assuming it is the most appropriate recipient (!!)"
+ scroller hasSubmorphs ifTrue:
+ [scroller submorphs last mouseDown: (evt transformedBy: (scroller transformFrom: self))]!
Item was added:
+ ----- Method: ScrollPane>>mouseEnter: (in category 'event handling') -----
+ mouseEnter: event
+ Preferences mouseOverForKeyboardFocus ifTrue:[hasFocus := true].
+ (owner isSystemWindow) ifTrue: [owner paneTransition: event].
+ retractableScrollBar ifTrue:[ self hideOrShowScrollBars ].
+ !
Item was added:
+ ----- Method: ScrollPane>>mouseLeave: (in category 'event handling') -----
+ mouseLeave: event
+ Preferences mouseOverForKeyboardFocus ifTrue:[hasFocus := false].
+ retractableScrollBar ifTrue: [self hideScrollBars].
+ (owner isSystemWindow) ifTrue: [owner paneTransition: event]
+ !
Item was added:
+ ----- Method: ScrollPane>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ "If pane is not empty, pass the event to the last submorph,
+ assuming it is the most appropriate recipient (!!)."
+ scroller hasSubmorphs ifTrue:
+ [scroller submorphs last mouseMove: (evt transformedBy: (scroller transformFrom: self))]!
Item was added:
+ ----- Method: ScrollPane>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+ "If pane is not empty, pass the event to the last submorph,
+ assuming it is the most appropriate recipient (!!)"
+ scroller hasSubmorphs ifTrue:
+ [scroller submorphs last mouseUp: (evt transformedBy: (scroller transformFrom: self))]!
Item was added:
+ ----- Method: ScrollPane>>numSelectionsInView (in category 'accessing') -----
+ numSelectionsInView
+ "Answer the scroller's height based on the average number of submorphs."
+
+ ^scroller numberOfItemsPotentiallyInView!
Item was added:
+ ----- Method: ScrollPane>>offsetToShow: (in category 'scrolling') -----
+ offsetToShow: aRectangle
+ "Calculate the offset necessary to show the rectangle."
+
+ | offset scrollRange |
+ offset := scroller offset.
+ scrollRange := self hUnadjustedScrollRange @ self vUnadjustedScrollRange.
+
+ "Vertical Scrolling"
+ (aRectangle top - offset y) < 0
+ ifTrue: [offset := offset x @ (
+ (aRectangle top min: scrollRange y - scroller height))].
+
+ ((aRectangle bottom - offset y) > scroller height and: [aRectangle height <= scroller height])
+ ifTrue: [offset := offset x @ (
+ (aRectangle top - scroller height + aRectangle height min: scrollRange y - scroller height))].
+
+ "Horizontal Scrolling"
+ (aRectangle left - offset x) < 0
+ ifTrue: [offset := (
+ (aRectangle left min: scrollRange x - scroller width)) @ offset y].
+
+ ((aRectangle right - offset x) > scroller width and: [aRectangle width <= scroller width])
+ ifTrue: [offset := (
+ (aRectangle left - scroller width + aRectangle width min: scrollRange x - scroller width)) @ offset y].
+
+ ^ offset!
Item was added:
+ ----- Method: ScrollPane>>resetExtent (in category 'geometry') -----
+ resetExtent
+ "Reset the extent. (may be overridden by subclasses which need to do more than this)"
+ self resizeScroller!
Item was added:
+ ----- Method: ScrollPane>>resizeScrollBars (in category 'geometry') -----
+ resizeScrollBars
+ self vResizeScrollBar; hResizeScrollBar
+ !
Item was added:
+ ----- Method: ScrollPane>>resizeScroller (in category 'geometry') -----
+ resizeScroller
+
+ scroller bounds: self innerBounds!
Item was added:
+ ----- Method: ScrollPane>>retractable: (in category 'menu') -----
+ retractable: aBoolean
+ retractableScrollBar == aBoolean ifFalse: [self retractableOrNot "toggles it"]!
Item was added:
+ ----- Method: ScrollPane>>retractableOrNot (in category 'menu') -----
+ retractableOrNot
+ "Change scroll bar operation"
+
+ retractableScrollBar := retractableScrollBar not.
+ retractableScrollBar
+ ifTrue: [self removeMorph: scrollBar]
+ ifFalse: [(submorphs includes: scrollBar)
+ ifFalse:
+ [self privateAddMorph: scrollBar atIndex: 1.
+ self privateAddMorph: hScrollBar atIndex: 1]].
+ self extent: self extent.
+ !
Item was added:
+ ----- Method: ScrollPane>>retractableScrollBar (in category 'access') -----
+ retractableScrollBar
+ ^ retractableScrollBar!
Item was added:
+ ----- Method: ScrollPane>>scrollBarFills: (in category 'geometry testing') -----
+ scrollBarFills: aRectangle
+ "Return true if a flop-out scrollbar fills the rectangle"
+
+ retractableScrollBar ifFalse:[^false].
+
+ ((submorphs includes: scrollBar) and: [scrollBar bounds containsRect: aRectangle])
+ ifTrue:[ ^true ].
+ ^((submorphs includes: hScrollBar) and: [hScrollBar bounds containsRect: aRectangle])
+ !
Item was added:
+ ----- Method: ScrollPane>>scrollBarMenuButtonPressed: (in category 'scroll bar events') -----
+ scrollBarMenuButtonPressed: event
+ ^ self yellowButtonActivity: event shiftPressed!
Item was added:
+ ----- Method: ScrollPane>>scrollBarOnLeft (in category 'access') -----
+ scrollBarOnLeft
+ ^ scrollBarOnLeft!
Item was added:
+ ----- Method: ScrollPane>>scrollBarOnLeft: (in category 'menu') -----
+ scrollBarOnLeft: aBoolean
+ scrollBarOnLeft := aBoolean.
+ self extent: self extent!
Item was added:
+ ----- Method: ScrollPane>>scrollBarThickness (in category 'geometry') -----
+ scrollBarThickness
+ "Includes border"
+ | result |
+ result := Preferences scrollBarsNarrow
+ ifTrue: [10]
+ ifFalse: [14].
+
+ self flatColoredScrollBarLook
+ ifFalse: [result := result + 2].
+
+ ^ result!
Item was added:
+ ----- Method: ScrollPane>>scrollBy: (in category 'scrolling') -----
+ scrollBy: delta
+ "Move the contents in the direction delta."
+
+ self flag: #negated. "mt: Who uses this and why is does the expected behavor negate the delta?"
+ self vScrollBar scrollBy: delta y negated.
+ self hScrollBar scrollBy: delta x negated.!
Item was added:
+ ----- Method: ScrollPane>>scrollByKeyboard: (in category 'event handling') -----
+ scrollByKeyboard: event
+ "If event is ctrl+up/down then scroll and answer true"
+ (event controlKeyPressed or:[event commandKeyPressed]) ifFalse: [^ false].
+ event keyCharacter = Character arrowUp
+ ifTrue:
+ [scrollBar scrollUp: 3.
+ ^ true].
+ event keyCharacter = Character arrowDown
+ ifTrue:
+ [scrollBar scrollDown: 3.
+ ^ true].
+ "event keyCharacter = Character arrowRight
+ ifTrue:
+ [hScrollBar scrollDown: 3.
+ ^ true].
+ event keyCharacter = Character arrowLeft
+ ifTrue:
+ [hScrollBar scrollUp: 3.
+ ^ true]."
+ ^ false!
Item was added:
+ ----- Method: ScrollPane>>scrollDeltaHeight (in category 'geometry') -----
+ scrollDeltaHeight
+ "Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)."
+ ^ 10
+ !
Item was added:
+ ----- Method: ScrollPane>>scrollDeltaWidth (in category 'geometry') -----
+ scrollDeltaWidth
+ "Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)."
+
+ ^10
+ !
Item was added:
+ ----- Method: ScrollPane>>scrollToShow: (in category 'scrolling') -----
+ scrollToShow: aRectangle
+ "We have to lock the callback into me because rounding errors in scrollbar values would reset the offset to a different value. The given rectangle may not be visible anymore."
+
+ scroller offset: (self offsetToShow: aRectangle).
+ lockOffset := true.
+ self setScrollDeltas.
+ lockOffset := false.!
Item was added:
+ ----- Method: ScrollPane>>scroller (in category 'access') -----
+ scroller
+ ^ scroller!
Item was added:
+ ----- Method: ScrollPane>>scroller: (in category 'access') -----
+ scroller: aTransformMorph
+ scroller ifNotNil:[scroller delete].
+ scroller := aTransformMorph.
+ self addMorph: scroller.
+ self resizeScroller.!
Item was added:
+ ----- Method: ScrollPane>>setScrollDeltas (in category 'geometry') -----
+ setScrollDeltas
+ "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."
+
+ scroller hasSubmorphs ifFalse: [^ self].
+
+ "NOTE: fullbounds commented out now -- trying to find a case where this expensive step is necessary -- perhaps there is a less expensive way to handle that case."
+ "scroller fullBounds." "force recompute so that leftoverScrollRange will be up-to-date"
+ self hideOrShowScrollBars.
+ self vSetScrollDelta.
+ self hSetScrollDelta..
+ !
Item was added:
+ ----- Method: ScrollPane>>shiftedTextPaneMenuRequest (in category 'scroll bar events') -----
+ shiftedTextPaneMenuRequest
+ "The more... button was hit from the text-pane menu"
+
+ ^ self yellowButtonActivity: true!
Item was added:
+ ----- Method: ScrollPane>>shiftedYellowButtonActivity (in category 'scroll bar events') -----
+ shiftedYellowButtonActivity
+ ^ self yellowButtonActivity: true!
Item was added:
+ ----- Method: ScrollPane>>showHScrollBarOnlyWhenNeeded: (in category 'access options') -----
+ showHScrollBarOnlyWhenNeeded: bool
+ "Get rid of scroll bar for short panes that don't want it shown."
+
+ self setProperty: #noHScrollBarPlease toValue: bool.
+ self setProperty: #hScrollBarAlways toValue: bool.
+
+ self hHideOrShowScrollBar.
+ !
Item was added:
+ ----- Method: ScrollPane>>showScrollBars (in category 'scrolling') -----
+ showScrollBars
+ self vShowScrollBar; hShowScrollBar
+ !
Item was added:
+ ----- Method: ScrollPane>>showScrollBarsOnlyWhenNeeded: (in category 'access options') -----
+ showScrollBarsOnlyWhenNeeded: bool
+
+ self showHScrollBarOnlyWhenNeeded: bool.
+ self showVScrollBarOnlyWhenNeeded: bool.
+ !
Item was added:
+ ----- Method: ScrollPane>>showVScrollBarOnlyWhenNeeded: (in category 'access options') -----
+ showVScrollBarOnlyWhenNeeded: bool
+ "Get rid of scroll bar for short panes that don't want it shown."
+
+ self setProperty: #noVScrollBarPlease toValue: bool.
+ self setProperty: #vScrollBarAlways toValue: bool.
+ self vHideOrShowScrollBar.
+ !
Item was added:
+ ----- Method: ScrollPane>>unshiftedYellowButtonActivity (in category 'scroll bar events') -----
+ unshiftedYellowButtonActivity
+ ^ self yellowButtonActivity: false!
Item was added:
+ ----- Method: ScrollPane>>vExtraScrollRange (in category 'geometry') -----
+ vExtraScrollRange
+ "Return the amount of extra blank space to include below the bottom of the scroll content."
+ ^ 0
+ !
Item was added:
+ ----- Method: ScrollPane>>vHideOrShowScrollBar (in category 'scrolling') -----
+ vHideOrShowScrollBar
+
+ self vIsScrollbarNeeded
+ ifTrue:[ self vShowScrollBar ]
+ ifFalse:[ self vHideScrollBar ].
+ !
Item was added:
+ ----- Method: ScrollPane>>vHideScrollBar (in category 'scrolling') -----
+ vHideScrollBar
+ self vIsScrollbarShowing ifFalse: [^self].
+ self removeMorph: scrollBar.
+ retractableScrollBar ifFalse: [self resetExtent].
+
+ !
Item was added:
+ ----- Method: ScrollPane>>vIsScrollable (in category 'geometry testing') -----
+ vIsScrollable
+ "Return whether the verticle scrollbar is scrollable. If the contents of the pane are too small to scroll, return false."
+
+ ^ self vLeftoverScrollRange > 0!
Item was added:
+ ----- Method: ScrollPane>>vIsScrollbarNeeded (in category 'scrolling') -----
+ vIsScrollbarNeeded
+ "Return whether the verticle scrollbar is needed"
+
+ "Don't do anything with the retractable scrollbar unless we have focus"
+ retractableScrollBar & self hasFocus not ifTrue: [^false].
+
+ "Don't show it if we were told not to."
+ (self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]) ifTrue: [^false].
+
+ "Always show it if we were told to"
+ (self valueOfProperty: #vScrollBarAlways ifAbsent: [false]) ifTrue: [^true].
+
+ ^self vIsScrollable
+ !
Item was added:
+ ----- Method: ScrollPane>>vIsScrollbarShowing (in category 'geometry testing') -----
+ vIsScrollbarShowing
+ "Return true if a retractable scroll bar is currently showing"
+
+ ^submorphs includes: scrollBar
+ !
Item was added:
+ ----- Method: ScrollPane>>vIsScrolled (in category 'geometry testing') -----
+ vIsScrolled
+ "If the scroller is not set to y = 0, then the pane has been scrolled."
+ ^scroller offset y > 0
+ !
Item was added:
+ ----- Method: ScrollPane>>vLeftoverScrollRange (in category 'geometry') -----
+ vLeftoverScrollRange
+ "Return the entire scrolling range minus the currently viewed area."
+
+ ^ scroller hasSubmorphs
+ ifFalse: [0]
+ ifTrue: [self vTotalScrollRange - scroller height max: 0]
+ !
Item was added:
+ ----- Method: ScrollPane>>vResizeScrollBar (in category 'geometry') -----
+ vResizeScrollBar
+ | w topLeft border |
+ w := self scrollBarThickness.
+ border := self borderWidth.
+ topLeft := scrollBarOnLeft
+ ifTrue: [retractableScrollBar
+ ifTrue: [bounds topLeft - ((w - border) @ border negated)]
+ ifFalse: [bounds topLeft + (border @ border)]]
+ ifFalse: [retractableScrollBar
+ ifTrue: [bounds topRight - (border @ border negated)]
+ ifFalse: [bounds topRight - ((w + border) @ border negated)]].
+
+ scrollBar
+ bounds: (topLeft + ((scrollBarOnLeft ifTrue: [border negated] ifFalse: [border]) @ border negated)
+ extent: w @ self vScrollBarHeight)
+
+ !
Item was added:
+ ----- Method: ScrollPane>>vScrollBar (in category 'access') -----
+ vScrollBar
+ ^ scrollBar!
Item was added:
+ ----- Method: ScrollPane>>vScrollBarHeight (in category 'geometry') -----
+ vScrollBarHeight
+ | h |
+
+ h := bounds height "- (2 * borderWidth)".
+ (retractableScrollBar not and: [self hIsScrollbarNeeded])
+ ifTrue:[ h := h - self scrollBarThickness. ].
+
+ ^h
+ !
Item was added:
+ ----- Method: ScrollPane>>vScrollBarMenuButtonPressed: (in category 'scroll bar events') -----
+ vScrollBarMenuButtonPressed: event
+ ^ self scrollBarMenuButtonPressed: event
+ !
Item was added:
+ ----- Method: ScrollPane>>vScrollBarValue: (in category 'scrolling') -----
+ vScrollBarValue: scrollValue
+
+ scroller hasSubmorphs ifFalse: [^ self].
+ lockOffset == true ifFalse: [
+ scroller offset: scroller offset x @ scrollValue].
+ !
Item was added:
+ ----- Method: ScrollPane>>vSetScrollDelta (in category 'geometry') -----
+ vSetScrollDelta
+ "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."
+
+ | delta |
+ delta := self scrollDeltaHeight.
+
+ scrollBar
+ truncate: true;
+ scrollDelta: delta
+ pageDelta: 10*delta;
+ maximumValue: self vLeftoverScrollRange;
+ interval: (self vTotalScrollRange = 0
+ ifTrue: [1.0]
+ ifFalse: [scroller height / self vTotalScrollRange]);
+ setValue: scroller offset y.!
Item was added:
+ ----- Method: ScrollPane>>vShowScrollBar (in category 'scrolling') -----
+ vShowScrollBar
+
+ self vIsScrollbarShowing ifTrue: [^ self].
+ self vResizeScrollBar.
+ self privateAddMorph: scrollBar atIndex: 1.
+ retractableScrollBar ifFalse: [self resetExtent]
+ !
Item was added:
+ ----- Method: ScrollPane>>vTotalScrollRange (in category 'geometry') -----
+ vTotalScrollRange
+ "Return the entire scrolling range."
+ ^ self vUnadjustedScrollRange + self vExtraScrollRange
+ !
Item was added:
+ ----- Method: ScrollPane>>vUnadjustedScrollRange (in category 'geometry') -----
+ vUnadjustedScrollRange
+ "Return the height extent of the receiver's submorphs."
+ | submorphBounds |
+ submorphBounds := scroller localSubmorphBounds ifNil: [^ 0].
+ ^ submorphBounds bottom
+ !
Item was added:
+ ----- Method: ScrollPane>>wantsKeyboardFocus (in category 'event handling') -----
+ wantsKeyboardFocus
+
+ ^ true!
Item was added:
+ ----- Method: ScrollPane>>wantsSlot (in category 'access') -----
+ wantsSlot
+ "For now do it the old way, until we sort this out"
+ ^ true!
Item was added:
+ ----- Method: ScrollPane>>wantsYellowButtonMenu (in category 'menu') -----
+ wantsYellowButtonMenu
+ "Answer true if the receiver wants a yellow button menu"
+ ^ getMenuSelector notNil!
Item was added:
+ ----- Method: ScrollPane>>yellowButtonActivity: (in category 'scroll bar events') -----
+ yellowButtonActivity: shiftKeyState
+ | menu |
+ (menu := self getMenu: shiftKeyState) ifNotNil:
+ [menu setInvokingView: self.
+ menu popUpEvent: self activeHand lastEvent in: self world]!
Item was added:
+ Model subclass: #SearchBar
+ instanceVariableNames: 'searchTerm selection resultsWidget'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus-DockingBar'!
Item was added:
+ ----- Method: SearchBar class>>build (in category 'as yet unclassified') -----
+ build
+
+ ^ ToolBuilder build: self new!
Item was added:
+ ----- Method: SearchBar>>activate:in: (in category 'accessing') -----
+ activate: event in: morph
+
+ self selection: (1 to: self searchTerm size).
+ event hand newKeyboardFocus: morph textMorph.!
Item was added:
+ ----- Method: SearchBar>>buildWith: (in category 'toolbuilder') -----
+ buildWith: builder
+
+ ^ (builder build: (builder pluggableInputFieldSpec new
+ model: self;
+ getText: #searchTerm;
+ setText: #smartSearch:in:;
+ editText: #searchTermSilently:;
+ menu: #menu:shifted:;
+ selection: #selection;
+ help: 'Search...' translated))
+ name: #searchBar;
+ wantsFrameAdornments: false;
+ borderWidth: 0;
+ yourself!
Item was added:
+ ----- Method: SearchBar>>menu:shifted: (in category 'accessing') -----
+ menu: aMenu shifted: aBoolean
+
+ ^ StringHolder codePaneMenu: aMenu shifted: aBoolean!
Item was added:
+ ----- Method: SearchBar>>printIt:result: (in category 'do-its') -----
+ printIt: code result: object
+
+ | focusedWidget |
+ focusedWidget := self currentHand keyboardFocus.
+
+ self removeResultsWidget.
+
+ ToolBuilder default in: [:builder |
+ resultsWidget := (builder build: (StringHolder new
+ contents: object asString;
+ buildCodePaneWith: builder)).
+ resultsWidget textMorph
+ on: #mouseLeave send: #delete to: resultsWidget.
+ resultsWidget
+ extent: 250 at 150;
+ fullBounds;
+ height: (resultsWidget textMorph height min: 300);
+ position: (focusedWidget
+ ifNotNil: [:w | w owner boundsInWorld bottomLeft]
+ ifNil: [self currentHand position]);
+ color: (BalloonMorph balloonColor alpha: 1.0).
+
+ Preferences menuAppearance3d
+ ifTrue: [resultsWidget addDropShadow].
+
+ resultsWidget openInWorld].!
Item was added:
+ ----- Method: SearchBar>>removeResultsWidget (in category 'accessing') -----
+ removeResultsWidget
+
+ resultsWidget ifNotNil: [:w | w delete].
+ resultsWidget := nil.!
Item was added:
+ ----- Method: SearchBar>>searchTerm (in category 'accessing') -----
+ searchTerm
+
+ ^ searchTerm ifNil: ['']!
Item was added:
+ ----- Method: SearchBar>>searchTerm: (in category 'accessing') -----
+ searchTerm: aString
+
+ searchTerm := aString.
+ self changed: #searchTerm.!
Item was added:
+ ----- Method: SearchBar>>searchTermSilently: (in category 'accessing') -----
+ searchTermSilently: aString.
+ "Do not signal it to the model."
+
+ searchTerm := aString.!
Item was added:
+ ----- Method: SearchBar>>selection (in category 'accessing') -----
+ selection
+
+ ^ selection ifNil: [1 to: 0]!
Item was added:
+ ----- Method: SearchBar>>selection: (in category 'accessing') -----
+ selection: anInterval
+
+ selection := anInterval.
+ self changed: #selection.!
Item was added:
+ ----- Method: SearchBar>>smartSearch:in: (in category 'searching') -----
+ smartSearch: text in: morph
+ "Take the user input and perform an appropriate search"
+ | input newContents |
+ self removeResultsWidget.
+ input := text asString ifEmpty:[^self].
+ (Smalltalk bindingOf: input) ifNotNil:[:assoc| | global |
+ "It's a global or a class"
+ global := assoc value.
+ ^ToolSet browse: (global isBehavior ifTrue:[global] ifFalse:[global class]) selector: nil.
+ ].
+ (SystemNavigation new allImplementorsOf: input asSymbol) ifNotEmpty:[:list|
+ ^SystemNavigation new
+ browseMessageList: list
+ name: 'Implementors of ' , input
+ ].
+ input first isUppercase ifTrue:[
+ (UIManager default classFromPattern: input withCaption: '') ifNotNil:[:aClass|
+ ^ToolSet browse: aClass selector: nil.
+ ].
+ ] ifFalse:[
+ ^ToolSet default browseMessageNames: input
+ ].
+ newContents := input, ' -- not found.'.
+
+ self searchTerm: newContents.
+ self selection: (input size+1 to: newContents size).
+ self currentHand newKeyboardFocus: morph textMorph.!
Item was added:
+ TextMorph subclass: #SearchBarMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus-DockingBar'!
Item was added:
+ ----- Method: SearchBarMorph>>activate: (in category 'search') -----
+ activate: event
+
+ event hand newKeyboardFocus: self.
+ self selectAll!
Item was added:
+ ----- Method: SearchBarMorph>>fillStyle (in category 'initialize') -----
+ fillStyle
+
+ ^backgroundColor!
Item was added:
+ ----- Method: SearchBarMorph>>initialize (in category 'initialize') -----
+ initialize
+
+ super initialize.
+ text := Text new.
+ backgroundColor := TranslucentColor gray alpha: 0.3.
+ self width: 200.
+ self crAction: (MessageSend receiver: self selector: #smartSearch:).
+ self setBalloonText: 'Searches for globals and methods'.!
Item was added:
+ ----- Method: SearchBarMorph>>smartSearch: (in category 'search') -----
+ smartSearch: evt
+ "Take the user input and perform an appropriate search"
+ | input newContents |
+ input := self contents asString ifEmpty:[^self].
+ (Smalltalk bindingOf: input) ifNotNil:[:assoc| | global |
+ "It's a global or a class"
+ global := assoc value.
+ ^ToolSet browse: (global isBehavior ifTrue:[global] ifFalse:[global class]) selector: nil.
+ ].
+ (SystemNavigation new allImplementorsOf: input asSymbol) ifNotEmpty:[:list|
+ ^SystemNavigation new
+ browseMessageList: list
+ name: 'Implementors of ' , input
+ ].
+ input first isUppercase ifTrue:[
+ (UIManager default classFromPattern: input withCaption: '') ifNotNil:[:aClass|
+ ^ToolSet browse: aClass selector: nil.
+ ].
+ ] ifFalse:[
+ ^ToolSet default browseMessageNames: input
+ ].
+ newContents := input, ' -- not found.'.
+ self
+ newContents: newContents;
+ selectFrom: input size+1 to: newContents size.
+ evt hand newKeyboardFocus: self!
Item was added:
+ ImageMorph subclass: #SelectedObjectThumbnail
+ instanceVariableNames: 'noSelectedThumbnail noSelectedBalloonText'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: SelectedObjectThumbnail class>>extent:noSelectedThumbnail:noSelectedBalloonText: (in category 'instance creation') -----
+ extent: aPoint noSelectedThumbnail: aForm noSelectedBalloonText: aString
+ ^ self new
+ initializeExtent: aPoint
+ noSelectedThumbnail: aForm
+ noSelectedBalloonText: aString !
Item was added:
+ ----- Method: SelectedObjectThumbnail>>initialize (in category 'initialization') -----
+ initialize
+ "Initialize the receiver"
+ super initialize.
+ ""
+ self
+ image: (Form extent:32 at 32).
+ self color: Color transparent!
Item was added:
+ ----- Method: SelectedObjectThumbnail>>initializeExtent:noSelectedThumbnail:noSelectedBalloonText: (in category 'initialization') -----
+ initializeExtent: aPoint noSelectedThumbnail: aForm noSelectedBalloonText: aString
+ self
+ image: (Form extent: aPoint).
+ ""
+ noSelectedThumbnail := aForm.
+ noSelectedBalloonText := aString!
Item was added:
+ ----- Method: SelectedObjectThumbnail>>makeEmptyThumbnail (in category 'private') -----
+ makeEmptyThumbnail
+
+ ^ self makeThumbnailOfColor: Color veryLightGray.
+ !
Item was added:
+ ----- Method: SelectedObjectThumbnail>>makeErrorThumbnail (in category 'private') -----
+ makeErrorThumbnail
+ ^ self makeThumbnailOfColor: Color red!
Item was added:
+ ----- Method: SelectedObjectThumbnail>>makeThumbnailFrom: (in category 'private') -----
+ makeThumbnailFrom: aMorphOrNil
+ | thumbnail |
+ thumbnail := aMorphOrNil isNil
+ ifTrue: [noSelectedThumbnail
+ ifNil: [self makeEmptyThumbnail]]
+ ifFalse: [aMorphOrNil iconOrThumbnail].
+ ""
+ self
+ image: (thumbnail scaledIntoFormOfSize: self extent)!
Item was added:
+ ----- Method: SelectedObjectThumbnail>>makeThumbnailOfColor: (in category 'private') -----
+ makeThumbnailOfColor: aColor
+ | form |
+ form := Form extent: self extent depth: 32.
+ form getCanvas fillColor: aColor.
+ self image: form!
Item was added:
+ ----- Method: SelectedObjectThumbnail>>noSelectedBalloonText: (in category 'accessing') -----
+ noSelectedBalloonText: aString
+ "Set the balloon text to be used when no object is selected"
+ noSelectedBalloonText := aString!
Item was added:
+ ----- Method: SelectedObjectThumbnail>>noSelectedThumbnail: (in category 'accessing') -----
+ noSelectedThumbnail: aForm
+ "Set the form to be used when no object is selected"
+ noSelectedThumbnail := aForm!
Item was added:
+ ----- Method: SelectedObjectThumbnail>>step (in category 'stepping and presenter') -----
+ step
+ | current |
+ current := self selectedObject.
+
+ self setBalloonText: (current isNil
+ ifTrue: [noSelectedBalloonText]
+ ifFalse: [current externalName]).
+ ""
+ self makeThumbnailFrom: current!
Item was added:
+ ----- Method: SelectedObjectThumbnail>>stepTime (in category 'stepping and presenter') -----
+ stepTime
+ ^ 125!
Item was added:
+ BorderedMorph subclass: #SelectionMorph
+ instanceVariableNames: 'selectedItems slippage dupLoc dupDelta itemsAlreadySelected otherSelection undoProperties'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !SelectionMorph commentStamp: '<historical>' prior: 0!
+ A selectionMorph supports the selection of multiple objects in a morphic world or pasteUp.
+
+ Structure:
+ selectedItems an OrderedCollection of Morphs
+ These are the morphs that have been selected
+ slippage a Point
+ Keeps track of actual movement between the
+ steps of gridded movement
+ dupLoc a Point
+ Notes the position when first duplicate request occurs from halo
+ dupDelta a Point
+ Holds the final delta of the first duplicate plus subsequent moves.
+ !
Item was added:
+ ----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') -----
+ defaultNameStemForInstances
+ ^ 'Selection'!
Item was added:
+ ----- Method: SelectionMorph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
+ aboutToBeGrabbedBy: aHand
+ slippage := 0 at 0.
+ ^ super aboutToBeGrabbedBy: aHand
+ !
Item was added:
+ ----- Method: SelectionMorph>>addCustomMenuItems:hand: (in category 'halo commands') -----
+ addCustomMenuItems: aMenu hand: aHandMorph
+ "Add custom menu items to the menu"
+
+ super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addLine.
+ aMenu add: 'add or remove items' translated target: self selector: #addOrRemoveItems: argument: aHandMorph.
+ aMenu addList: {
+ #-.
+ {'place into a row' translated. #organizeIntoRow}.
+ {'place into a column' translated. #organizeIntoColumn}.
+ #-.
+ {'align left edges' translated. #alignLeftEdges}.
+ {'align top edges' translated. #alignTopEdges}.
+ {'align right edges' translated. #alignRightEdges}.
+ {'align bottom edges' translated. #alignBottomEdges}.
+ #-.
+ {'align centers vertically' translated. #alignCentersVertically}.
+ {'align centers horizontally' translated. #alignCentersHorizontally}.
+ }.
+
+ self selectedItems size > 2
+ ifTrue:[
+ aMenu addList: {
+ #-.
+ {'distribute vertically' translated. #distributeVertically}.
+ {'distribute horizontally' translated. #distributeHorizontally}.
+ }.
+ ].
+ !
Item was added:
+ ----- Method: SelectionMorph>>addHandlesTo:box: (in category 'halos and balloon help') -----
+ addHandlesTo: aHaloMorph box: box
+ | onlyThese |
+ aHaloMorph haloBox: box.
+ onlyThese := #(addDismissHandle: addMenuHandle: addGrabHandle: addDragHandle: addDupHandle: addHelpHandle: addGrowHandle: addFontSizeHandle: addFontStyleHandle: addFontEmphHandle: addRecolorHandle:).
+ Preferences haloSpecifications do:
+ [:aSpec | (onlyThese includes: aSpec addHandleSelector) ifTrue:
+ [aHaloMorph perform: aSpec addHandleSelector with: aSpec]].
+ aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box!
Item was added:
+ ----- Method: SelectionMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
+ addOptionalHandlesTo: aHalo box: box
+ aHalo addHandleAt: box leftCenter color: Color blue icon: nil
+ on: #mouseUp send: #addOrRemoveItems: to: self.!
Item was added:
+ ----- Method: SelectionMorph>>addOrRemoveItems: (in category 'halo commands') -----
+ addOrRemoveItems: handOrEvent
+ "Make a new selection extending the current one."
+
+ | hand |
+ hand := (handOrEvent isMorphicEvent)
+ ifFalse: [handOrEvent]
+ ifTrue: [handOrEvent hand].
+ hand
+ addMorphBack: ((self class
+ newBounds: (hand lastEvent cursorPoint extent: 16 @ 16))
+ setOtherSelection: self).
+ !
Item was added:
+ ----- Method: SelectionMorph>>alignBottomEdges (in category 'halo commands') -----
+ alignBottomEdges
+ "Make the bottom coordinate of all my elements be the same"
+
+ | maxBottom |
+ maxBottom := (selectedItems collect: [:itm | itm bottom]) max.
+ selectedItems do:
+ [:itm | itm bottom: maxBottom].
+
+ self changed
+ !
Item was added:
+ ----- Method: SelectionMorph>>alignCentersHorizontally (in category 'halo commands') -----
+ alignCentersHorizontally
+ "Make every morph in the selection have the same vertical center as the topmost item."
+
+ | minLeft leftMost |
+ selectedItems size > 1 ifFalse: [^ self].
+ minLeft := (selectedItems collect: [:itm | itm left]) min.
+ leftMost := selectedItems detect: [:m | m left = minLeft].
+ selectedItems do:
+ [:itm | itm center: (itm center x @ leftMost center y)].
+
+ self changed
+ !
Item was added:
+ ----- Method: SelectionMorph>>alignCentersVertically (in category 'halo commands') -----
+ alignCentersVertically
+ "Make every morph in the selection have the same horizontal center as the topmost item."
+
+ | minTop topMost |
+ selectedItems size > 1 ifFalse: [^ self].
+ minTop := (selectedItems collect: [:itm | itm top]) min.
+ topMost := selectedItems detect: [:m | m top = minTop].
+ selectedItems do:
+ [:itm | itm center: (topMost center x @ itm center y)].
+
+ self changed
+ !
Item was added:
+ ----- Method: SelectionMorph>>alignLeftEdges (in category 'halo commands') -----
+ alignLeftEdges
+ "Make the left coordinate of all my elements be the same"
+
+ | minLeft |
+ minLeft := (selectedItems collect: [:itm | itm left]) min.
+ selectedItems do:
+ [:itm | itm left: minLeft].
+
+ self changed
+ !
Item was added:
+ ----- Method: SelectionMorph>>alignRightEdges (in category 'halo commands') -----
+ alignRightEdges
+ "Make the right coordinate of all my elements be the same"
+
+ | maxRight |
+ maxRight := (selectedItems collect: [:itm | itm right]) max.
+ selectedItems do:
+ [:itm | itm right: maxRight].
+
+ self changed
+ !
Item was added:
+ ----- Method: SelectionMorph>>alignTopEdges (in category 'halo commands') -----
+ alignTopEdges
+ "Make the top coordinate of all my elements be the same"
+
+ | minTop |
+ minTop := (selectedItems collect: [:itm | itm top]) min.
+ selectedItems do:
+ [:itm | itm top: minTop].
+
+ self changed
+ !
Item was added:
+ ----- Method: SelectionMorph>>balloonHelpTextForHandle: (in category 'halos and balloon help') -----
+ balloonHelpTextForHandle: aHandle
+ aHandle eventHandler firstMouseSelector == #addOrRemoveItems:
+ ifTrue: [^'Add items to, or remove them from, this selection.'].
+ ^ super balloonHelpTextForHandle: aHandle!
Item was added:
+ ----- Method: SelectionMorph>>borderColor: (in category 'accessing') -----
+ borderColor: aColor
+
+ | bordered |
+ bordered := selectedItems.
+ undoProperties ifNil: [undoProperties := bordered collect: [:m | m borderColor]].
+ bordered do: [:m | m borderColor: aColor]!
Item was added:
+ ----- Method: SelectionMorph>>borderColorForItems: (in category 'undo') -----
+ borderColorForItems: colorCollection
+
+ (selectedItems select: [:m | m isKindOf: BorderedMorph])
+ with: colorCollection
+ do: [:m :c | m borderColor: c]!
Item was added:
+ ----- Method: SelectionMorph>>borderWidth: (in category 'accessing') -----
+ borderWidth: aWidth
+
+ | bordered |
+ bordered := selectedItems select: [:m | m isKindOf: BorderedMorph].
+ undoProperties ifNil: [undoProperties := bordered collect: [:m | m borderWidth]].
+ bordered do: [:m | m borderWidth: aWidth]!
Item was added:
+ ----- Method: SelectionMorph>>borderWidthForItems: (in category 'undo') -----
+ borderWidthForItems: widthCollection
+
+ (selectedItems select: [:m | m isKindOf: BorderedMorph])
+ with: widthCollection
+ do: [:m :c | m borderWidth: c]!
Item was added:
+ ----- Method: SelectionMorph>>bounds: (in category 'geometry') -----
+ bounds: newBounds
+ "Make sure position: gets called before extent:; Andreas' optimization for growing/shrinking in ChangeSet 3119 screwed up selection of morphs from underlying pasteup."
+
+ selectedItems := OrderedCollection new. "Avoid repostioning items during super position:"
+ self position: newBounds topLeft; extent: newBounds extent
+ !
Item was added:
+ ----- Method: SelectionMorph>>couldMakeSibling (in category 'testing') -----
+ couldMakeSibling
+ "Answer whether it is appropriate to ask the receiver to make a sibling"
+
+ ^ false!
Item was added:
+ ----- Method: SelectionMorph>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ (Preferences menuSelectionColor ifNil: [Color blue]) twiceDarker alpha: 0.75!
Item was added:
+ ----- Method: SelectionMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 2!
Item was added:
+ ----- Method: SelectionMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ (Preferences menuSelectionColor ifNil: [Color blue]) alpha: 0.08
+ !
Item was added:
+ ----- Method: SelectionMorph>>delete (in category 'submorphs-add/remove') -----
+ delete
+ self setProperty: #deleting toValue: true.
+ super delete.
+ !
Item was added:
+ ----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
+ dismissViaHalo
+
+ super dismissViaHalo.
+ selectedItems do: [:m | m dismissViaHalo]!
Item was added:
+ ----- Method: SelectionMorph>>distributeHorizontally (in category 'halo commands') -----
+ distributeHorizontally
+ "Distribute the empty vertical space in a democratic way."
+ | minLeft maxRight totalWidth currentLeft space |
+
+ self selectedItems size > 2
+ ifFalse: [^ self].
+
+ minLeft := self selectedItems anyOne left.
+ maxRight := self selectedItems anyOne right.
+ totalWidth := 0.
+ self selectedItems
+ do: [:each |
+ minLeft := minLeft min: each left.
+ maxRight := maxRight max: each right.
+ totalWidth := totalWidth + each width].
+
+ currentLeft := minLeft.
+ space := (maxRight - minLeft - totalWidth / (self selectedItems size - 1)) rounded.
+ (self selectedItems
+ asSortedCollection: [:x :y | x left <= y left])
+ do: [:each |
+ each left: currentLeft.
+ currentLeft := currentLeft + each width + space].
+
+ self changed
+ !
Item was added:
+ ----- Method: SelectionMorph>>distributeVertically (in category 'halo commands') -----
+ distributeVertically
+ "Distribute the empty vertical space in a democratic way."
+ | minTop maxBottom totalHeight currentTop space |
+ self selectedItems size > 2
+ ifFalse: [^ self].
+
+ minTop := self selectedItems anyOne top.
+ maxBottom := self selectedItems anyOne bottom.
+ totalHeight := 0.
+ self selectedItems
+ do: [:each |
+ minTop := minTop min: each top.
+ maxBottom := maxBottom max: each bottom.
+ totalHeight := totalHeight + each height].
+
+ currentTop := minTop.
+ space := (maxBottom - minTop - totalHeight / (self selectedItems size - 1)) rounded.
+ (self selectedItems asSortedCollection:[:x :y | x top <= y top])
+ do: [:each |
+ each top: currentTop.
+ currentTop := currentTop + each height + space].
+
+ self changed
+ !
Item was added:
+ ----- Method: SelectionMorph>>doDup:fromHalo:handle: (in category 'halo commands') -----
+ doDup: evt fromHalo: halo handle: dupHandle
+
+ selectedItems := self duplicateMorphCollection: selectedItems.
+ selectedItems do: [:m | self owner addMorph: m].
+ dupDelta isNil
+ ifTrue: ["First duplicate operation -- note starting location"
+ dupLoc := self position.
+ evt hand grabMorph: self.
+ halo removeAllHandlesBut: dupHandle]
+ ifFalse: ["Subsequent duplicate does not grab, but only moves me and my morphs"
+ dupLoc := nil.
+ self position: self position + dupDelta]
+ !
Item was added:
+ ----- Method: SelectionMorph>>doneExtending (in category 'private') -----
+ doneExtending
+
+ otherSelection ifNotNil:
+ [selectedItems := otherSelection selectedItems , selectedItems.
+ otherSelection delete.
+ self setOtherSelection: nil].
+ self changed.
+ self layoutChanged.
+ super privateBounds:
+ ((Rectangle merging: (selectedItems collect: [:m | m fullBounds]))
+ expandBy: 8).
+ self changed.
+ self addHalo.!
Item was added:
+ ----- Method: SelectionMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ | canvas form1 form2 box |
+ super drawOn: aCanvas.
+ box := self bounds copy.
+ selectedItems do: [:m | box swallow: m fullBounds].
+ box := box expandBy: 1.
+ canvas := Display defaultCanvasClass extent: box extent depth: 8.
+ canvas translateBy: box topLeft negated
+ during: [:tempCanvas | selectedItems do: [:m | tempCanvas fullDrawMorph: m]].
+ form1 := (Form extent: box extent) copyBits: (0 at 0 extent: box extent) from: canvas form at: 0 at 0 colorMap: (Color maskingMap: 8).
+ form2 := Form extent: box extent.
+ (0 at 0) fourNeighbors do: [:d | form1 displayOn: form2 at: d rule: Form under].
+ form1 displayOn: form2 at: 0 at 0 rule: Form erase.
+ aCanvas stencil: form2
+ at: box topLeft
+ sourceRect: form2 boundingBox
+ color: self borderColor
+ !
Item was added:
+ ----- Method: SelectionMorph>>duplicate (in category 'halo commands') -----
+ duplicate
+ "Make a duplicate of the receiver and havbe the hand grab it"
+
+ selectedItems := self duplicateMorphCollection: selectedItems.
+ selectedItems reverseDo: [:m | (owner ifNil: [ActiveWorld]) addMorph: m].
+ dupLoc := self position.
+ ActiveHand grabMorph: self.
+ ActiveWorld presenter flushPlayerListCache!
Item was added:
+ ----- Method: SelectionMorph>>extendByHand: (in category 'initialization') -----
+ extendByHand: aHand
+ "Assumes selection has just been created and added to some pasteUp or world"
+ | startPoint handle |
+
+ startPoint := self position.
+
+ handle := NewHandleMorph new followHand: aHand
+ forEachPointDo: [:newPoint |
+ | localPt |
+ localPt := (self transformFrom: self world) globalPointToLocal: newPoint.
+ self bounds: (startPoint rect: localPt)
+ ]
+ lastPointDo: [:newPoint |
+ selectedItems isEmpty
+ ifTrue: [self delete]
+ ifFalse: [
+ selectedItems size = 1
+ ifTrue:[self delete. selectedItems anyOne addHalo]
+ ifFalse:[self doneExtending]
+ ]
+ ].
+
+ aHand attachMorph: handle.
+ handle startStepping.!
Item was added:
+ ----- Method: SelectionMorph>>extent: (in category 'geometry') -----
+ extent: newExtent
+
+ super extent: newExtent.
+ self selectSubmorphsOf: self pasteUpMorph!
Item was added:
+ ----- Method: SelectionMorph>>externalName (in category 'viewer') -----
+ externalName
+ ^ 'Selected {1} objects' translated format:{self selectedItems size}!
Item was added:
+ ----- Method: SelectionMorph>>fillStyle: (in category 'visual properties') -----
+ fillStyle: aColor
+ undoProperties ifNil: [undoProperties := selectedItems collect: [:m | m fillStyle]].
+ selectedItems do: [:m | m fillStyle: aColor]!
Item was added:
+ ----- Method: SelectionMorph>>fillStyleForItems: (in category 'undo') -----
+ fillStyleForItems: fillStyleCollection
+
+ selectedItems with: fillStyleCollection do: [:m :c | m fillStyle: c]!
Item was added:
+ ----- Method: SelectionMorph>>hasHalo: (in category 'halos and balloon help') -----
+ hasHalo: aBool
+ super hasHalo: aBool.
+ aBool
+ ifFalse: [ (self hasProperty: #deleting) ifFalse: [self delete] ]
+ !
Item was added:
+ ----- Method: SelectionMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+
+ selectedItems := OrderedCollection new.
+ itemsAlreadySelected := OrderedCollection new.
+ slippage := 0 @ 0!
Item was added:
+ ----- Method: SelectionMorph>>isSelectionMorph (in category 'testing') -----
+ isSelectionMorph
+ ^true!
Item was added:
+ ----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: newOwner event: evt
+
+ selectedItems isEmpty ifTrue:
+ ["Hand just clicked down to draw out a new selection"
+ ^ self extendByHand: evt hand].
+ dupLoc ifNotNil: [dupDelta := self position - dupLoc].
+ selectedItems reverseDo: [:m |
+ WorldState addDeferredUIMessage:
+ [m referencePosition: (newOwner localPointToGlobal: m referencePosition).
+ newOwner handleDropMorph:
+ (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
+ evt wasHandled: true!
Item was added:
+ ----- Method: SelectionMorph>>maybeAddCollapseItemTo: (in category 'menus') -----
+ maybeAddCollapseItemTo: aMenu
+ "... don't "!
Item was added:
+ ----- Method: SelectionMorph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+ "helpful for insuring some morphs always appear in front of or
+ behind others. smaller numbers are in front"
+ ^ 8!
Item was added:
+ ----- Method: SelectionMorph>>organizeIntoColumn (in category 'halo commands') -----
+ organizeIntoColumn
+ "Place my objects in a column-enforcing container"
+
+ ((AlignmentMorph inAColumn: (selectedItems asSortedCollection: [:x :y | x top < y top])) setNameTo: 'Column'; color: Color orange muchLighter; enableDragNDrop: true; yourself) openInHand
+ !
Item was added:
+ ----- Method: SelectionMorph>>organizeIntoRow (in category 'halo commands') -----
+ organizeIntoRow
+ "Place my objects in a row-enforcing container"
+
+ ((AlignmentMorph inARow: (selectedItems asSortedCollection: [:x :y | x left < y left])) setNameTo: 'Row'; color: Color orange muchLighter; enableDragNDrop: true; yourself) openInHand
+ !
Item was added:
+ ----- Method: SelectionMorph>>preferredDuplicationHandleSelector (in category 'testing') -----
+ preferredDuplicationHandleSelector
+ "Answer the selector, to be offered as the default in a halo open on me"
+
+ ^ #addDupHandle:!
Item was added:
+ ----- Method: SelectionMorph>>privateFullMoveBy: (in category 'private') -----
+ privateFullMoveBy: delta
+
+ | griddedDelta griddingMorph |
+ selectedItems isEmpty ifTrue: [^ super privateFullMoveBy: delta].
+ griddingMorph := self pasteUpMorph.
+ griddingMorph ifNil: [^ super privateFullMoveBy: delta].
+ griddedDelta := (griddingMorph gridPoint: self position + delta + slippage) -
+ (griddingMorph gridPoint: self position).
+ slippage := slippage + (delta - griddedDelta). "keep track of how we lag the true movement."
+ griddedDelta = (0 at 0) ifTrue: [^ self].
+ super privateFullMoveBy: griddedDelta.
+ selectedItems do:
+ [:m | m position: (m position + griddedDelta) ]
+ !
Item was added:
+ ----- Method: SelectionMorph>>refineUndoTarget:selector:arguments:in: (in category 'undo') -----
+ refineUndoTarget: target selector: selector arguments: arguments in: refineBlock
+ "Any morph can override this method to refine its undo specification"
+ selector == #fillStyle: ifTrue:
+ [refineBlock value: target value: #fillStyleForItems: value: {undoProperties}.
+ ^ undoProperties := nil].
+ selector == #borderColor: ifTrue:
+ [refineBlock value: target value: #borderColorForItems: value: {undoProperties}.
+ ^ undoProperties := nil].
+ selector == #borderWidth: ifTrue:
+ [refineBlock value: target value: #borderWidthForItems: value: {undoProperties}.
+ ^ undoProperties := nil].
+ selector == #undoMove:redo:owner:bounds:predecessor: ifTrue:
+ ["This is the biggy. Need to gather parameters for all selected items"
+ refineBlock value: target
+ value: #undoMove:redo:owner:bounds:predecessor:
+ value: {arguments first.
+ arguments second.
+ selectedItems collect: [:m | m owner].
+ selectedItems collect: [:m | m bounds].
+ selectedItems collect: [:m | m owner morphPreceding: m]}].
+ refineBlock value: target value: selector value: arguments!
Item was added:
+ ----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') -----
+ selectSubmorphsOf: aMorph
+
+ | newItems removals |
+ newItems := aMorph submorphs select:
+ [:m | (bounds containsRect: m fullBounds)
+ and: [m~~self
+ and: [(m isKindOf: HaloMorph) not]]].
+ otherSelection ifNil: [^ selectedItems := newItems].
+
+ removals := newItems intersection: itemsAlreadySelected.
+ otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
+ selectedItems := (newItems copyWithoutAll: removals).
+ !
Item was added:
+ ----- Method: SelectionMorph>>selectedItems (in category 'private') -----
+ selectedItems
+
+ ^ selectedItems!
Item was added:
+ ----- Method: SelectionMorph>>setOtherSelection: (in category 'private') -----
+ setOtherSelection: otherOrNil
+ otherSelection := otherOrNil.
+ otherOrNil isNil
+ ifTrue: [super borderColor: Color blue]
+ ifFalse:
+ [itemsAlreadySelected := otherSelection selectedItems.
+ super borderColor: Color green]!
Item was added:
+ ----- Method: SelectionMorph>>setSelectedItems: (in category 'private') -----
+ setSelectedItems: items
+
+ selectedItems := items.
+ self changed!
Item was added:
+ ----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') -----
+ slideToTrash: evt
+ self delete.
+ selectedItems do: [:m | m slideToTrash: evt]!
Item was added:
+ ----- Method: SelectionMorph>>undoMove:redo:owner:bounds:predecessor: (in category 'undo') -----
+ undoMove: cmd redo: redo owner: oldOwners bounds: oldBoundses predecessor: oldPredecessors
+ "Handle undo and redo of move commands in morphic"
+
+ | item |
+ redo
+ ifFalse:
+ ["undo sets up the redo state first"
+
+ cmd
+ redoTarget: self
+ selector: #undoMove:redo:owner:bounds:predecessor:
+ arguments: {
+ cmd.
+ true.
+ selectedItems collect: [:m | m owner].
+ selectedItems collect: [:m | m bounds].
+ selectedItems collect: [:m | m owner morphPreceding: m]}].
+ 1 to: selectedItems size do:
+ [:i |
+ item := selectedItems at: i.
+ (oldOwners at: i) ifNotNil:
+ [(oldPredecessors at: i) ifNil: [(oldOwners at: i) addMorphFront: item]
+ ifNotNil: [(oldOwners at: i) addMorph: item after: (oldPredecessors at: i)]].
+ item bounds: (oldBoundses at: i).
+ item isSystemWindow ifTrue: [item activate]]!
Item was added:
+ ----- Method: SelectionMorph>>wantsToBeTopmost (in category 'accessing') -----
+ wantsToBeTopmost
+ "Answer if the receiver want to be one of the topmost objects in
+ its owner"
+ ^ true!
Item was added:
+ ----- Method: SequenceableCollection>>asCubic (in category '*Morphic-NewCurves-cubic support') -----
+ asCubic
+ "Convert this point array to a Cubic object"
+ self
+ assert: [self size = 4].
+ self
+ assert: [self
+ allSatisfy: [:each | each isPoint]].
+ ^ Cubic withAll: self!
Item was added:
+ ----- Method: SequenceableCollection>>assertSlopesWith:from:to: (in category '*Morphic-NewCurves-cubic support') -----
+ assertSlopesWith: knots from: start to: end
+ "
+ We trust everything has been checked.
+ The following assertions should hold at this point: "
+
+ self assert: [ self size = knots size ] .
+ "Sizes must be consistent."
+ self assert: [ end > start].
+ "There must be at least one slope to clamp."
+ self assert: [ 0 < start and: [start <= knots size] ].
+ "The clamped slope may be the last one."
+ self assert: [ end <= knots size + start ] .
+ "We can wrap. There may be only one known slope."
+ "xxx self assert: [ end = knots size + start ifTrue: [ (self at: start) notNil ] ] . xxx"
+ "xxx If we overlap slope must be known. xxx"
+ { start . end }
+ do: [ :index |
+ | slope |
+ slope := (self at: index ).
+ self assert: [ slope isNil
+ or: [ slope isNumber
+ or: [ slope isPoint ] ] ] ] .
+ "And a known and reasonalble value or nil."
+ ^true
+ !
Item was added:
+ ----- Method: SequenceableCollection>>changeInSlopes: (in category '*Morphic-NewCurves-cubic support') -----
+ changeInSlopes: slopes
+ "A message to knots of a spline. Returns an array with the 3rd cubic coeff."
+ "The last nth item is correct iff this is a closed cubic.
+ Presumably that is the only time we care.
+ We always return the same sized array as self."
+ | n slopeChanges |
+ n := self size.
+ n = slopes size
+ ifFalse: [^ self error: 'vertices and slopes differ in number'].
+ slopeChanges := Array new: n.
+ (1 to: n)
+ do: [:i | slopeChanges at: i put: (self atWrap: i + 1)
+ - (self at: i) * 3 - ((slopes at: i)
+ * 2)
+ - (slopes atWrap: i + 1)].
+
+ ^ slopeChanges!
Item was added:
+ ----- Method: SequenceableCollection>>changeOfChangesInSlopes: (in category '*Morphic-NewCurves-cubic support') -----
+ changeOfChangesInSlopes: slopes
+ "A message to knots of a spline. Returns an array with the 4rd
+ cubic coeff."
+ "The last nth item is correct iff this is a closed cubic.
+ Presumably that is the only time we care.
+ We always return the same sized array as self."
+ | n changes |
+ n := self size.
+ n = slopes size
+ ifFalse: [^ self error: 'vertices and slopes differ in number'].
+ changes := Array new: n.
+ 1 to: n do: [ :i |
+ changes at: i put: (self at: i)
+ - (self atWrap: i + 1) * 2
+ + (slopes at: i)
+ + (slopes atWrap: i + 1) ].
+ ^ changes!
Item was added:
+ ----- Method: SequenceableCollection>>closedCubicSlopes (in category '*Morphic-NewCurves-cubic support') -----
+ closedCubicSlopes
+ "Sent to knots returns the slopes of a closed cubic spline.
+ From the same set of java sources as naturalCubic. This is a squeak
+ transliteration of the java code."
+ "from java code NatCubicClosed extends NatCubic
+ solves for the set of equations for all knots:
+ b1+4*b2+b3=3*(a3-a1)
+ where a1 is (knots atWrap: index + 1) etc.
+ and the b's are the slopes .
+
+ by decomposing the matrix into upper triangular and lower matrices
+ and then back sustitution. See Spath 'Spline Algorithms for Curves
+ and Surfaces' pp 19--21. The D[i] are the derivatives at the knots.
+ "
+
+ | v w x y z n1 D F G H |
+ n1 := self size.
+ n1 < 3
+ ifTrue: [self error: 'Less than 3 points makes a poor curve'].
+ v := Array new: n1.
+ w := Array new: n1.
+ y := Array new: n1.
+
+ D := Array new: n1.
+ x := self.
+ z := 1.0 / 4.0.
+ v at: 2 put: z.
+ w at: 2 put: z.
+ y at: 1 put: z * 3.0 * ((x at: 2)
+ - (x at: n1)).
+ H := 4.0.
+ F := 3 * ((x at: 1)
+ - (x at: n1 - 1)).
+ G := 1.
+ 2 to: n1 - 1
+ do: [:k |
+ z := 1.0 / (4.0
+ - (v at: k)).
+ v at: k + 1 put: z.
+ w at: k + 1 put: z negated
+ * (w at: k).
+ y at: k put: z * (3.0 * ((x at: k + 1)
+ - (x at: k - 1))
+ - (y at: k - 1)).
+ H := H - (G
+ * (w at: k)).
+ F := F - (G
+ * (y at: k - 1)).
+ G := (v at: k) negated * G].
+ H := H - (G + 1 * ((v at: n1)
+ + (w at: n1))).
+ y at: n1 put: F - (G + 1
+ * (y at: n1 - 1)).
+ D at: n1 put: (y at: n1)
+ / H.
+ D at: n1 - 1 put: (y at: n1 - 1)
+ - ((v at: n1)
+ + (w at: n1)
+ * (D at: n1)).
+ n1 - 2 to: 1 by: -1 do: [ :k |
+ D at: k put:
+ (y at: k)
+ - ((v at: k + 1)
+ * (D at: k + 1)) - ((w at: k + 1)
+ * (D at: n1))].
+ ^ D .!
Item was added:
+ ----- Method: SequenceableCollection>>closedCubicSlopes: (in category '*Morphic-NewCurves-cubic support') -----
+ closedCubicSlopes: clampedSlopes
+ "Sent to knots returns a copy of clampedSlopes with the values of the undefined (nil) slopes filled in.
+ "
+ " clampedSlopes must be the same size as knots)"
+
+ "/* Between known slopes we solve the equation for knots with end conditions:
+ 4*b1+b2 = 3(a2 - a0) - b0
+ bN2+4*bN1 = 3*(aN-aN2) - bN
+ and inbetween:
+ b2+4*b3+b4=3*(a4-a2)
+ where a2 is (knots atWrap: index + 1) etc.
+ and the b's are the slopes .
+ N is the last index (knots size)
+ N1 is N-1.
+
+ by using row operations to convert the matrix to upper
+ triangular and then back substitution.
+ "
+ | slopes tripleKnots list |
+ (list := clampedSlopes closedFillinList) = { 0 to: self size } ifTrue: [ ^ self closedCubicSlopes ] .
+ "Special case all unknown."
+
+ tripleKnots := self * 3.0 .
+ " Premultiply and convert numbers or point coords to Floats "
+ slopes := clampedSlopes copy. "slopes contents will be modified."
+
+ list do: [ :r | slopes slopesWith: tripleKnots from: r first to: r last ] .
+
+ ^ slopes!
Item was added:
+ ----- Method: SequenceableCollection>>closedFillinList (in category '*Morphic-NewCurves-cubic support') -----
+ closedFillinList
+ "Answers a list of ranges between which values are undertermined.
+ Reciever is a list that combines known values and nil entries for
+ undetermined values.
+ Answer a list of ranges. Each range starts and ends with a known
+ value.
+ The range inbetween the known values are nil. The ranges start and
+ ends may overlap.
+ Each nil element in the list appears in exactly one range.
+ If the list starts or ends with nil the last range will wrap around to the
+ next known value. There may be only one known value in the list but
+ there must be atleast one know value.
+
+ (self allsatisfy: [ :e | e isNil ] ) ifTrue: [ self error: 'list must contain at
+ least one known value' ]
+ "
+ | changes n |
+ changes := self nilTransitions .
+ changes isEmpty ifTrue: [ ^ { 0 to: self size } "Special case. All unknowns." ] .
+
+ changes = #(1) ifTrue: [ ^ #() "Special case. no unknowns." ] .
+ changes = { n := self size } ifTrue: [ ^ { n to: n + n } ] .
+ "Special case. Only last element known."
+
+ changes size even ifTrue:
+ [changes add: self size
+ + (changes at: 1)]
+ ifFalse: [
+ changes first = 1 ifFalse: [ changes add: self size + 1;
+ add: self size + changes first ]
+
+ ].
+ ^ changes allButFirst pairsCollect: [ :s :e | ( s - 1 to: e ) ] .
+
+ !
Item was added:
+ ----- Method: SequenceableCollection>>cubicPointPolynomialAt: (in category '*Morphic-NewCurves-cubic support') -----
+ cubicPointPolynomialAt: vIndex
+ "From curve information assemble a 4-array of points representing the coefficents for curve segment between to points. Beginning point is first point in array endpoint is the pointSum of the array. Meant to be sent to newcurves idea of curve coefficents."
+
+ | result |
+ result := Cubic new: 4.
+ 1 to: 4 do: [ :i |
+ result at: i put: ((self at: i) at: vIndex) @ ((self at: 4 + i) at: vIndex) ].
+ ^result!
Item was added:
+ ----- Method: SequenceableCollection>>explorerContents (in category '*Morphic-Explorer') -----
+ explorerContents
+
+ ^Array new: self size streamContents: [ :stream |
+ 1 to: self size do: [ :index |
+ stream nextPut: (
+ ObjectExplorerWrapper
+ with: (self at: index)
+ name: index printString
+ model: self) ] ]!
Item was added:
+ ----- Method: SequenceableCollection>>flipRotated: (in category '*Morphic-fliprotate') -----
+ flipRotated: flipIndex
+ "Answer a copy of the receiver with element order indicated by
+ flipIndex."
+ "Examples:"
+ "'frog' flipRotated: 1"
+ "[ :c | (1 to: c size * 2) collect:
+ [ :i | c flipRotated: i ]
+ ] value: 'frog'."
+ "Lsb of flipIndex indicates whether list is reversed"
+ "The flipIndex // 2 gives how much to rotate by after reversing"
+ "A good way to think of this is a piece of pie in a pie plate being flip
+ over its leading edge successively."
+ "flipIndex > 2 * n are allowed to make it possible to store an array of
+ indexes in an integer."
+ | n result src twist |
+ n := self size.
+ flipIndex \\ (n * 2) = 0
+ ifTrue: [^ self].
+ "allow for doing nothing"
+ result := self species new: n.
+ twist := flipIndex // 2 \\ n.
+ src := 0.
+ (flipIndex even
+ ifTrue: [1 + twist to: n + twist]
+ ifFalse: [n - 1 - twist to: twist negated by: -1])
+ do: [:i | result
+ at: (src := src + 1)
+ put: (self atWrap: i)].
+ ^ result!
Item was added:
+ ----- Method: SequenceableCollection>>naturalCubicSlopes (in category '*Morphic-NewCurves-cubic support') -----
+ naturalCubicSlopes
+ "Sent to knots returns the slopes of a natural cubic curve fit.
+ This is a direct squeak
+ transliteration of the java code."
+ " public class NatCubic extends ControlCurve
+
+ /* We solve the equation for knots with end conditions:
+ 2*b1+b2 = 3(a1 - a0)
+ bN1+2*bN = 3*(aN-aN1)
+ and inbetween:
+ b2+4*b3+b4=3*(a4-a2)
+ where a2 is (knots atWrap: index + 1) etc.
+ and the b's are the slopes .
+ N is the last index (knots size)
+ N1 is N-1.
+
+ by using row operations to convert the matrix to upper
+ triangular
+ and then back sustitution. The D[i] are the derivatives at the
+ knots.
+ "
+ | x gamma delta D n1 |
+ n1 := self size.
+ n1 < 3
+ ifTrue: [self error: 'Less than 3 points makes a poor curve'].
+ x := self.
+ gamma := Array new: n1.
+ delta := Array new: n1.
+
+ D := Array new: n1.
+ gamma at: 1 put: 1.0 / 2.0.
+ (2 to: n1 - 1)
+ do: [:i | gamma at: i put: 1.0 / (4.0
+ - (gamma at: i - 1))].
+ gamma at: n1 put: 1.0 / (2.0
+ - (gamma at: n1 - 1)).
+ delta at: 1 put: 3.0 * ((x at: 2)
+ - (x at: 1))
+ * (gamma at: 1).
+ (2 to: n1 - 1)
+ do: [:i | delta at: i put: 3.0 * ((x at: i + 1)
+ - (x at: i - 1))
+ - (delta at: i - 1)
+ * (gamma at: i)].
+ delta at: n1 put: 3.0 * ((x at: n1)
+ - (x at: n1 - 1))
+ - (delta at: n1 - 1)
+ * (gamma at: n1).
+ D
+ at: n1
+ put: (delta at: n1).
+ (1 to: n1 - 1)
+ reverseDo: [:i | D at: i put: (delta at: i)
+ - ((gamma at: i)
+ * (D at: i + 1))].
+ ^ D!
Item was added:
+ ----- Method: SequenceableCollection>>naturalCubicSlopes: (in category '*Morphic-NewCurves-cubic support') -----
+ naturalCubicSlopes: clampedSlopes
+ "Sent to knots returns a copy of clampedSlopes with the values of the undefined (nil) slopes filled in.
+ "
+ " clampedSlopes must be the same size as knots)"
+
+ "/* Between known slopes we solve the equation for knots with end conditions:
+ 4*b1+b2 = 3(a2 - a0) - b0
+ bN2+4*bN1 = 3*(aN-aN2) - bN
+ and inbetween:
+ b2+4*b3+b4=3*(a4-a2)
+ where a2 is (knots atWrap: index + 1) etc.
+ and the b's are the slopes .
+ N is the last index (knots size)
+ N1 is N-1.
+
+ by using row operations to convert the matrix to upper
+ triangular and then back substitution.
+ "
+ | slopes tripleKnots |
+ tripleKnots := self * 3.0 .
+ " Premultiply and convert numbers or point coords to Floats "
+ slopes := clampedSlopes copy. "slopes will be modified."
+ clampedSlopes naturalFillinList do: [ :r | slopes slopesWith: tripleKnots from: r first to: r last ] .
+
+ ^ slopes!
Item was added:
+ ----- Method: SequenceableCollection>>naturalFillinList (in category '*Morphic-NewCurves-cubic support') -----
+ naturalFillinList
+ "Return a list of fillin ranges to be used to calculate natural or clamped slopes.
+ Note that this list is slightly different in mission from the closedFillinList"
+ "Answers a list of ranges between which value are undertermined.
+ Reciever is a list that combines known values and nil entries for
+ undetermined values.
+ Answer a list of ranges. Each range starts and ends with a known value.
+ With the exception of the first and last slopes on the list which may be unknown.
+ If no slopes are known then the only range is the whole list.
+ If all slopes are known then the fillin list is empty.
+ The range inbetween the known values are nil. The ranges start and
+ ends may overlap if the slope at the overlap is known.
+ Each nil element in the list appears in exactly one range.
+ "
+ | changes |
+ changes := self nilTransitions .
+ changes isEmpty ifTrue: [ ^ { 1 to: self size } "Special case all unknown." ] .
+
+ changes = #(1) ifTrue: [ ^ #() "Special case. no unknowns." ] .
+
+ changes size even
+ ifTrue: [changes add: self size ] . "Last slope is unknown"
+ changes first = 1
+ ifTrue: [ ^ changes allButFirst pairsCollect: [ :s :e | ( s - 1 to: e ) ] ] .
+
+ "Otherwise first slope is unknown."
+
+
+ ^ { 1 to: changes first } ,
+ (changes allButFirst pairsCollect: [ :s :e | ( ( s - 1) to: e ) ])
+
+ !
Item was added:
+ ----- Method: SequenceableCollection>>nilTransitions (in category '*Morphic-NewCurves-cubic support') -----
+ nilTransitions
+ "Return an OrderedCollection of transition indexes.
+ Indexes represent where the list elements transitions
+ from nil to nonNil
+ or from nonNil to nil.
+ 1 is an index in the list iff the first element is nonNil. "
+
+ | changes nilSkip |
+
+ changes := OrderedCollection new.
+ nilSkip := true .
+
+ 1 to: self size
+ do: [:i | (self atWrap: i) isNil == nilSkip
+ ifFalse: [changes add: i.
+ nilSkip := nilSkip not]].
+
+ ^ changes !
Item was added:
+ ----- Method: SequenceableCollection>>segmentedSlopes (in category '*Morphic-NewCurves-cubic support') -----
+ segmentedSlopes
+ "For a collection of floats. Returns the slopes for straight
+ segments between vertices."
+ "last slope closes the polygon. Always return same size as
+ self. "
+ ^ self
+ collectWithIndex: [:x :i | (self atWrap: i + 1)
+ - x]!
Item was added:
+ ----- Method: SequenceableCollection>>slopesWith:from:to: (in category '*Morphic-NewCurves-cubic support') -----
+ slopesWith: tripleKnots from: start to: end
+ "Sent to modifiable list of slopes. Fills in the slope values between start
+ and end. Start and end slopes can be either clamped or nil.
+ If nil the natural slope for that value will be filled in.
+ We expect that the parameters meets the assertions in
+ self assertSlopesWith: knots from: start to: end."
+ "
+
+ /* We solve the equation for knots with end conditions either known or unknown:
+ 4*b1+b2 = 3*(a2 - a0) - b0 b0 known
+ Or
+ 2*b0+b1 = 3*(a1 - a0) . b0 == nil
+
+ bN2+4*bN1 = 3*(aN-aN2)-bN bN known
+ Or
+ bN1+2*bN = 3*(aN-aN1) bN == nil
+ .
+ b0, bN are starting and ending slopes.
+
+ We now handle the special closed cubic case where a0 == aN ( i.e. N = knots size )
+ and b0 == bN == nil .
+
+
+
+
+ and inbetween:
+ b2+4*b3+b4=3*(a4-a2)
+ where a2 is (knots atWrap: index + 1) etc.
+ and the b's are the slopes .
+ by using row operations to convert the matrix to upper
+ triangular and then back substitution.
+ "
+ | gamma delta n range isOpenRange |
+ n := self size.
+ gamma := Array new: n.
+ delta := Array new: n.
+ isOpenRange := end < (start + self size) .
+ (self at: start)
+ ifNotNil: [
+ gamma at: start put: 0.0.
+ delta
+ at: start
+ put: (self at: start).
+ range := ( start + 1 to: end - 1 ) .
+ ] " clamped initial conditions"
+ ifNil: [
+ isOpenRange
+ ifTrue:
+ [gamma at: start put: 2.0 reciprocal.
+ delta
+ at: start
+ put: ((tripleKnots atWrap: start + 1)
+ - tripleKnots at: start ) * (gamma at: start) .
+ range := ( start to: end - 1 ) . ] "natural initial conditions "
+ ifFalse:
+ [ gamma at: start put: 4.0 reciprocal.
+ delta
+ at: start
+ put: ((tripleKnots atWrap: start + 1)
+ - tripleKnots atWrap: start - 1 ) * (gamma at: start) .
+ range := ( start + 1 to: end - 1 ) .
+ ] "closed initial conditions "
+ ] .
+ (start + 1 to: end - 1)
+ do: [:i | gamma atWrap: i put: 1.0 / (4.0
+ - (gamma atWrap: i - 1))].
+ (start + 1 to: end - 1)
+ do: [:i | delta atWrap: i put: ((tripleKnots atWrap: i + 1)
+ - (tripleKnots atWrap: i - 1))
+ - (delta atWrap: i - 1)
+ * (gamma atWrap: i)].
+ (self atWrap: end)
+ ifNil: [ isOpenRange
+ ifTrue: [
+ gamma atWrap: end put: 1.0 / (2.0
+ - (gamma atWrap: end - 1 )).
+ delta
+ atWrap: end
+ put: ((tripleKnots atWrap: end )
+ - tripleKnots atWrap: end - 1 )
+ - (delta at: end - 1 ) * (gamma atWrap: end)] "natural end conditions"
+ ifFalse: [
+ gamma atWrap: end put: 1.0 / (4.0
+ - (gamma atWrap: end - 1 )).
+ delta
+ atWrap: end
+ put: ((tripleKnots atWrap: end + 1 )
+ - tripleKnots atWrap: end - 1 )
+ - (delta at: end - 1 ) * (gamma atWrap: end)] "closed end conditions"
+ .
+ self atWrap: end put: (delta atWrap: end ) .
+ ]
+ ifNotNil: [
+ gamma atWrap: end put: 0.0 .
+ delta
+ atWrap: end
+ put: (self atWrap: end) .
+
+ ] "clamped end conditions" .
+
+ range
+ reverseDo: [:i | self atWrap: i put:
+ (delta atWrap: i)
+ - ((gamma atWrap: i)
+ * (self atWrap: i + 1)) ] .
+ " reciever now contains the filled in slopes."
+ ^ self !
Item was added:
+ ----- Method: SequenceableCollection>>transitions (in category '*Morphic-NewCurves-cubic support') -----
+ transitions
+ "Sent to a list of boolean values.
+ Return an OrderedCollection of transition indexes.
+ Indexes represent where the list elements transitions
+ from true to false
+ or from false to true.
+ 1 is an index in the list iff the first element is false. "
+
+ | changes boolSkip |
+
+ changes := OrderedCollection new.
+ boolSkip := true .
+
+ self
+ withIndexDo: [:truth :i | truth == boolSkip
+ ifFalse: [changes add: i.
+ boolSkip := boolSkip not]].
+
+ ^ changes !
Item was added:
+ ----- Method: SequenceableCollection>>transitions: (in category '*Morphic-NewCurves-cubic support') -----
+ transitions: aSelectBlock
+ "Sent to a list. Select block returns a boolean
+ Return an OrderedCollection of transition indexes.
+ Indexes represent where the list elements transitions
+ from true to false
+ or from false to true.
+ 1 is an index in the list iff the first element tests false. "
+
+ | changes boolSkip |
+
+ changes := OrderedCollection new.
+ boolSkip := true .
+
+ self withIndexDo:
+ [:e :i | (aSelectBlock value: e ) == boolSkip
+ ifFalse: [changes add: i.
+ boolSkip := boolSkip not]].
+
+ ^ changes !
Item was added:
+ ----- Method: Set>>explorerContents (in category '*Morphic-Explorer') -----
+ explorerContents
+
+ ^Array new: self size streamContents: [ :stream |
+ self do: [ :each |
+ stream nextPut: (
+ ObjectExplorerWrapper
+ with: each
+ name: (stream position + 1) printString
+ model: self) ] ]!
Item was added:
+ ----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
+ hasContentsInExplorer
+
+ ^self isEmpty not!
Item was added:
+ ColorMappingCanvas subclass: #ShadowDrawingCanvas
+ instanceVariableNames: 'shadowColor'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: ShadowDrawingCanvas>>image:at:sourceRect:rule: (in category 'private') -----
+ image: aForm at: aPoint sourceRect: sourceRect rule: rule
+ "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle."
+ rule = Form paint ifTrue:[
+ ^myCanvas
+ stencil: aForm
+ at: aPoint
+ sourceRect: sourceRect
+ color: shadowColor
+ ] ifFalse:[
+ ^myCanvas
+ fillRectangle: (sourceRect translateBy: aPoint)
+ color: shadowColor
+ ].!
Item was added:
+ ----- Method: ShadowDrawingCanvas>>isShadowDrawing (in category 'testing') -----
+ isShadowDrawing
+ ^true!
Item was added:
+ ----- Method: ShadowDrawingCanvas>>mapColor: (in category 'private') -----
+ mapColor: aColor
+ aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..."
+ ^aColor isTransparent
+ ifTrue:[aColor]
+ ifFalse:[shadowColor]!
Item was added:
+ ----- Method: ShadowDrawingCanvas>>on: (in category 'initialization') -----
+ on: aCanvas
+ myCanvas := aCanvas.
+ shadowColor := Color black.!
Item was added:
+ ----- Method: ShadowDrawingCanvas>>shadowColor (in category 'accessing') -----
+ shadowColor
+ ^shadowColor!
Item was added:
+ ----- Method: ShadowDrawingCanvas>>shadowColor: (in category 'accessing') -----
+ shadowColor: aColor
+ shadowColor := aColor!
Item was added:
+ BorderStyle subclass: #SimpleBorder
+ instanceVariableNames: 'baseColor color width'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Borders'!
+
+ !SimpleBorder commentStamp: 'kfr 10/27/2003 10:17' prior: 0!
+ see BorderedMorph!
Item was added:
+ ----- Method: SimpleBorder>>baseColor (in category 'accessing') -----
+ baseColor
+ ^baseColor ifNil:[Color transparent]!
Item was added:
+ ----- Method: SimpleBorder>>baseColor: (in category 'accessing') -----
+ baseColor: aColor
+ | cc |
+ cc := aColor isTransparent ifTrue:[nil] ifFalse:[aColor].
+ baseColor = cc ifTrue:[^self].
+ baseColor := cc.
+ self releaseCachedState.
+ self color: cc.
+ !
Item was added:
+ ----- Method: SimpleBorder>>bottomRightColor (in category 'accessing') -----
+ bottomRightColor
+ ^color!
Item was added:
+ ----- Method: SimpleBorder>>color (in category 'accessing') -----
+ color
+ ^color ifNil:[Color transparent]!
Item was added:
+ ----- Method: SimpleBorder>>color: (in category 'accessing') -----
+ color: aColor
+ color = aColor ifTrue:[^self].
+ color := aColor.
+ self releaseCachedState.!
Item was added:
+ ----- Method: SimpleBorder>>drawLineFrom:to:on: (in category 'drawing') -----
+ drawLineFrom: startPoint to: stopPoint on: aCanvas
+ | lineColor |
+ lineColor := (stopPoint truncated quadrantOf: startPoint truncated) > 2
+ ifTrue: [self topLeftColor]
+ ifFalse: [self bottomRightColor].
+ aCanvas
+ line: startPoint
+ to: stopPoint
+ width: self width
+ color: lineColor!
Item was added:
+ ----- Method: SimpleBorder>>frameRectangle:on: (in category 'drawing') -----
+ frameRectangle: aRectangle on: aCanvas
+ aCanvas frameAndFillRectangle: aRectangle
+ fillColor: Color transparent
+ borderWidth: self width
+ topLeftColor: self topLeftColor
+ bottomRightColor: self bottomRightColor.!
Item was added:
+ ----- Method: SimpleBorder>>style (in category 'accessing') -----
+ style
+ ^#simple!
Item was added:
+ ----- Method: SimpleBorder>>topLeftColor (in category 'accessing') -----
+ topLeftColor
+ ^color!
Item was added:
+ ----- Method: SimpleBorder>>width (in category 'accessing') -----
+ width
+ ^width!
Item was added:
+ ----- Method: SimpleBorder>>width: (in category 'accessing') -----
+ width: aNumber
+ width = aNumber ifTrue:[^self].
+ width := aNumber truncated max: (width isPoint ifTrue:[0 at 0] ifFalse:[0]).
+ self releaseCachedState.!
Item was added:
+ SimpleButtonMorph subclass: #SimpleButtonDelayedMenuMorph
+ instanceVariableNames: 'didMenu'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: SimpleButtonDelayedMenuMorph>>handlesMouseStillDown: (in category 'event handling') -----
+ handlesMouseStillDown: evt
+
+ ^true!
Item was added:
+ ----- Method: SimpleButtonDelayedMenuMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+
+ didMenu := nil.
+ super mouseDown: evt.
+ !
Item was added:
+ ----- Method: SimpleButtonDelayedMenuMorph>>mouseStillDown: (in category 'event handling') -----
+ mouseStillDown: evt
+ (mouseDownTime isNil or: [(Time millisecondClockValue - mouseDownTime) abs < 1000]) ifTrue: [
+ ^super mouseStillDown: evt
+ ].
+ didMenu ifNotNil: [^super mouseStillDown: evt].
+ self color: oldColor. "in case menu never returns"
+ didMenu := target showMenuFor: actionSelector event: evt.
+ !
Item was added:
+ ----- Method: SimpleButtonDelayedMenuMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+
+ didMenu == true ifFalse: [^super mouseUp: evt].
+ oldColor ifNotNil: [
+ self color: oldColor.
+ oldColor := nil
+ ].!
Item was added:
+ RectangleMorph subclass: #SimpleButtonMorph
+ instanceVariableNames: 'target actionSelector arguments actWhen oldColor mouseDownTime'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !SimpleButtonMorph commentStamp: 'ul 7/22/2010 04:30' prior: 0!
+ I am labeled, rectangular morph which allows the user to click me. I can be configured to send my "target" the message "actionSelector" with "arguments" when I am clicked. I may have a label, implemented as a StringMorph.
+
+ Example:
+
+ SimpleButtonMorph new
+ target: Beeper;
+ label: 'Beep!!';
+ actionSelector: #beep;
+ openInWorld
+
+ Structure:
+ instance var Type Description
+ target Object The Object to notify upon a click
+ actionSelector Symbol The message to send to Target (#messageName)
+ arguments Array Arguments to send with #actionSelection (optional)
+ actWhen Symbol When to take action: may be #buttonUp (default), #buttonDown,
+ #whilePressed, or #startDrag
+ oldColor Color Used to restore color after click
+
+ Another example: a button which quits the image without saving it.
+
+ SimpleButtonMorph new
+ target: Smalltalk;
+ label: 'quit';
+ actionSelector: #snapshot:andQuit:;
+ arguments: (Array with: false with: true);
+ openInWorld
+
+ !
Item was added:
+ ----- Method: SimpleButtonMorph class>>authoringPrototype (in category 'scripting') -----
+ authoringPrototype
+ ^ super authoringPrototype label: 'Button'!
Item was added:
+ ----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') -----
+ defaultNameStemForInstances
+ ^ self = SimpleButtonMorph
+ ifTrue: ['Button']
+ ifFalse: [^ super defaultNameStemForInstances]!
Item was added:
+ ----- Method: SimpleButtonMorph class>>newWithLabel: (in category 'as yet unclassified') -----
+ newWithLabel: labelString
+
+ ^ self basicNew initializeWithLabel: labelString
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>actWhen (in category 'submorphs-add/remove') -----
+ actWhen
+ "acceptable symbols: #buttonDown, #buttonUp, and #whilePressed"
+
+ ^ actWhen!
Item was added:
+ ----- Method: SimpleButtonMorph>>actWhen: (in category 'submorphs-add/remove') -----
+ actWhen: condition
+ "Accepts symbols: #buttonDown, #buttonUp, and #whilePressed, #startDrag"
+ actWhen := condition.
+ actWhen == #startDrag
+ ifFalse: [self on: #startDrag send: nil to: nil ]
+ ifTrue:[self on: #startDrag send: #doButtonAction to: self].!
Item was added:
+ ----- Method: SimpleButtonMorph>>actionSelector (in category 'accessing') -----
+ actionSelector
+
+ ^ actionSelector
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>actionSelector: (in category 'accessing') -----
+ actionSelector: aSymbolOrString
+
+ (nil = aSymbolOrString or:
+ ['nil' = aSymbolOrString or:
+ [aSymbolOrString isEmpty]])
+ ifTrue: [^ actionSelector := nil].
+
+ actionSelector := aSymbolOrString asSymbol.
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ self addLabelItemsTo: aCustomMenu hand: aHandMorph.
+ (target isKindOf: BookMorph)
+ ifTrue:
+ [aCustomMenu add: 'set page sound' translated action: #setPageSound:.
+ aCustomMenu add: 'set page visual' translated action: #setPageVisual:]
+ ifFalse:
+ [aCustomMenu add: 'change action selector' translated action: #setActionSelector.
+ aCustomMenu add: 'change arguments' translated action: #setArguments.
+ aCustomMenu add: 'change when to act' translated action: #setActWhen.
+ self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>addLabelItemsTo:hand: (in category 'menu') -----
+ addLabelItemsTo: aCustomMenu hand: aHandMorph
+ aCustomMenu add: 'change label' translated action: #setLabel!
Item was added:
+ ----- Method: SimpleButtonMorph>>addTargetingMenuItems:hand: (in category 'menu') -----
+ addTargetingMenuItems: aCustomMenu hand: aHandMorph
+ "Add targeting menu items"
+ aCustomMenu addLine.
+
+ aCustomMenu add: 'set target' translated action: #targetWith:.
+ aCustomMenu add: 'sight target' translated action: #sightTargets:.
+ target
+ ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]!
Item was added:
+ ----- Method: SimpleButtonMorph>>arguments (in category 'accessing') -----
+ arguments
+
+ ^ arguments
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>arguments: (in category 'accessing') -----
+ arguments: aCollection
+
+ arguments := aCollection asArray copy.
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>clearTarget (in category 'menu') -----
+ clearTarget
+
+ target := nil.
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>doButtonAction (in category 'button') -----
+ doButtonAction
+ "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."
+
+ (target notNil and: [actionSelector notNil])
+ ifTrue:
+ [Cursor normal
+ showWhile: [target perform: actionSelector withArguments: arguments]].
+ actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]!
Item was added:
+ ----- Method: SimpleButtonMorph>>extent: (in category 'geometry') -----
+ extent: newExtent
+ | label |
+ super extent: newExtent.
+ submorphs size = 1 ifTrue:
+ ["keep the label centered"
+ "NOTE: may want to test more that it IS a label..."
+ label := self firstSubmorph.
+ label position: self center - (label extent // 2)]!
Item was added:
+ ----- Method: SimpleButtonMorph>>fitContents (in category 'accessing') -----
+ fitContents
+ | aMorph aCenter |
+ aCenter := self center.
+ submorphs isEmpty ifTrue: [^self].
+ aMorph := submorphs first.
+ self extent: aMorph extent + (borderWidth + 6).
+ self center: aCenter.
+ aMorph position: aCenter - (aMorph extent // 2)!
Item was added:
+ ----- Method: SimpleButtonMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ ^ self isPartsDonor not
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>handlesMouseStillDown: (in category 'event handling') -----
+ handlesMouseStillDown: evt
+ ^actWhen == #whilePressed!
Item was added:
+ ----- Method: SimpleButtonMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ self initializeAllButLabel; setDefaultLabel!
Item was added:
+ ----- Method: SimpleButtonMorph>>initializeAllButLabel (in category 'initialization') -----
+ initializeAllButLabel
+ super initialize.
+ self
+ borderWidth: 1 ;
+ color: (Color r: 0.4 g: 0.8 b: 0.6) ;
+ borderColor: self color darker ;
+ borderStyle: BorderStyle thinGray.
+ target := nil.
+ actionSelector := #flash.
+ arguments := Array empty.
+ actWhen := #buttonUp!
Item was added:
+ ----- Method: SimpleButtonMorph>>initializeWithLabel: (in category 'initialization') -----
+ initializeWithLabel: labelString
+
+ self initializeAllButLabel; label: labelString
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>label (in category 'accessing') -----
+ label
+
+ | s |
+ s := ''.
+ self allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [s := m contents]].
+ ^ s!
Item was added:
+ ----- Method: SimpleButtonMorph>>label: (in category 'accessing') -----
+ label: aString
+
+ | oldLabel m |
+ (oldLabel := self findA: StringMorph)
+ ifNotNil: [oldLabel delete].
+ m := StringMorph contents: aString font: TextStyle defaultFont.
+ self extent: m extent + (borderWidth + 6).
+ m position: self center - (m extent // 2).
+ self addMorph: m.
+ m lock!
Item was added:
+ ----- Method: SimpleButtonMorph>>label:font: (in category 'accessing') -----
+ label: aString font: aFont
+
+ | oldLabel m |
+ (oldLabel := self findA: StringMorph)
+ ifNotNil: [oldLabel delete].
+ m := StringMorph contents: aString font: (aFont ifNil: [Preferences standardButtonFont]).
+ self extent: (m width + 6) @ (m height + 6).
+ m position: self center - (m extent // 2).
+ self addMorph: m.
+ m lock
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>labelString: (in category 'accessing') -----
+ labelString: aString
+
+ | existingLabel |
+ (existingLabel := self findA: StringMorph)
+ ifNil:
+ [self label: aString]
+ ifNotNil:
+ [existingLabel contents: aString.
+ self fitContents]
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+
+ super mouseDown: evt.
+ evt yellowButtonPressed ifTrue: [ ^self ] .
+ mouseDownTime := Time millisecondClockValue.
+ oldColor := self fillStyle.
+ actWhen == #buttonDown
+ ifTrue: [ self doButtonAction]
+ ifFalse: [ self updateVisualState: evt ].
+ self mouseStillDown: evt.!
Item was added:
+ ----- Method: SimpleButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ actWhen == #buttonDown ifTrue: [^ self].
+ self updateVisualState: evt.!
Item was added:
+ ----- Method: SimpleButtonMorph>>mouseStillDown: (in category 'event handling') -----
+ mouseStillDown: evt
+ actWhen == #whilePressed ifFalse:[^self].
+ (self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].!
Item was added:
+ ----- Method: SimpleButtonMorph>>mouseStillDownStepRate (in category 'events-processing') -----
+ mouseStillDownStepRate
+ "Answer how often I want the #handleMouseStillDown: stepped"
+ ^200!
Item was added:
+ ----- Method: SimpleButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+ super mouseUp: evt.
+ oldColor ifNotNil:
+ ["if oldColor nil, it signals that mouse had not gone DOWN
+ inside me, e.g. because of a cmd-drag; in this case we want
+ to avoid triggering the action!!"
+ self color: oldColor.
+ oldColor := nil.
+ (self containsPoint: evt cursorPoint)
+ ifTrue: [ actWhen == #buttonUp
+ ifTrue: [self doButtonAction] ]
+ ifFalse: [ self mouseLeave: evt "This is a balk. Note that we have left." ]]
+
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>objectForDataStream: (in category 'objects from disk') -----
+ objectForDataStream: refStrm
+ "I am about to be written on an object file. If I send a message to a BookMorph, it would be bad to write that object out. Create and write out a URLMorph instead."
+
+ | bb thatPage um stem ind sqPg |
+ (actionSelector == #goToPageMorph:fromBookmark:) |
+ (actionSelector == #goToPageMorph:) ifFalse: [
+ ^ super objectForDataStream: refStrm]. "normal case"
+
+ target url ifNil: ["Later force target book to get a url."
+ bb := SimpleButtonMorph new. "write out a dummy"
+ bb label: self label.
+ bb bounds: bounds.
+ refStrm replace: self with: bb.
+ ^ bb].
+
+ (thatPage := arguments first) url ifNil: [
+ "Need to assign a url to a page that will be written later.
+ It might have bookmarks too. Don't want to recurse deeply.
+ Have that page write out a dummy morph to save its url on the server."
+ stem := target getStemUrl. "know it has one"
+ ind := target pages identityIndexOf: thatPage.
+ thatPage reserveUrl: stem,(ind printString),'.sp'].
+ um := URLMorph newForURL: thatPage url.
+ sqPg := thatPage sqkPage clone.
+ sqPg contentsMorph: nil.
+ um setURL: thatPage url page: sqPg.
+ (SqueakPage stemUrl: target url) = (SqueakPage stemUrl: thatPage url)
+ ifTrue: [um book: true]
+ ifFalse: [um book: target url]. "remember which book"
+ um privateOwner: owner.
+ um bounds: bounds.
+ um isBookmark: true; label: self label.
+ um borderWidth: borderWidth; borderColor: borderColor.
+ um color: color.
+ refStrm replace: self with: um.
+ ^ um!
Item was added:
+ ----- Method: SimpleButtonMorph>>recolor: (in category 'copying') -----
+ recolor: c
+ self color: c.
+ oldColor := c!
Item was added:
+ ----- Method: SimpleButtonMorph>>setActWhen (in category 'menu') -----
+ setActWhen
+
+ | selections |
+ selections := #(buttonDown buttonUp whilePressed startDrag).
+ actWhen := UIManager default
+ chooseFrom: (selections collect: [:t | t translated])
+ values: selections
+ title: 'Choose one of the following conditions' translated.!
Item was added:
+ ----- Method: SimpleButtonMorph>>setActionSelector (in category 'menu') -----
+ setActionSelector
+
+ | newSel |
+ newSel := UIManager default
+ request:
+ 'Please type the selector to be sent to
+ the target when this button is pressed' translated
+ initialAnswer: actionSelector.
+ newSel isEmpty ifFalse: [self actionSelector: newSel].
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>setArguments (in category 'menu') -----
+ setArguments
+
+ | s newArgs newArgsArray |
+ s := WriteStream on: ''.
+ arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].
+ newArgs := UIManager default
+ request:
+ 'Please type the arguments to be sent to the target
+ when this button is pressed separated by periods' translated
+ initialAnswer: s contents.
+ newArgs isEmpty ifFalse: [
+ newArgsArray := Compiler evaluate: '{', newArgs, '}' for: self.
+ self arguments: newArgsArray].
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>setDefaultLabel (in category 'initialization') -----
+ setDefaultLabel
+ self label: 'Flash'.
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>setLabel (in category 'menu') -----
+ setLabel
+
+ | newLabel |
+ newLabel := UIManager default
+ request: 'Please enter a new label for this button'
+ initialAnswer: self label.
+ newLabel isEmpty ifFalse: [self labelString: newLabel].
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>setPageSound: (in category 'menu') -----
+ setPageSound: event
+
+ ^ target menuPageSoundFor: self event: event!
Item was added:
+ ----- Method: SimpleButtonMorph>>setPageVisual: (in category 'menu') -----
+ setPageVisual: event
+
+ ^ target menuPageVisualFor: self event: event!
Item was added:
+ ----- Method: SimpleButtonMorph>>setTarget (in category 'menu') -----
+ setTarget
+
+ | newLabel |
+ newLabel := UIManager default request: 'Enter an expression that create the target' translated initialAnswer: 'World'.
+ newLabel isEmpty
+ ifFalse: [self target: (Compiler evaluate: newLabel)]!
Item was added:
+ ----- Method: SimpleButtonMorph>>setTarget: (in category 'menu') -----
+ setTarget: evt
+ | rootMorphs |
+ rootMorphs := self world rootMorphsAt: evt hand targetPoint.
+ target := rootMorphs size > 1
+ ifTrue: [rootMorphs second]!
Item was added:
+ ----- Method: SimpleButtonMorph>>target (in category 'accessing') -----
+ target
+
+ ^ target
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>target: (in category 'accessing') -----
+ target: anObject
+
+ target := anObject
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>updateVisualState: (in category 'visual properties') -----
+ updateVisualState: evt
+
+ oldColor ifNotNil: [
+ self color:
+ ((self containsPoint: evt cursorPoint)
+ ifTrue: [oldColor mixed: 1/2 with: Color white]
+ ifFalse: [oldColor])]
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ target := deepCopier references at: target ifAbsent: [target].
+ arguments := arguments collect: [:each |
+ deepCopier references at: each ifAbsent: [each]].
+ !
Item was added:
+ ----- Method: SimpleButtonMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ "target := target. Weakly copied"
+ "actionSelector := actionSelector. a Symbol"
+ "arguments := arguments. All weakly copied"
+ actWhen := actWhen veryDeepCopyWith: deepCopier.
+ oldColor := oldColor veryDeepCopyWith: deepCopier.
+ mouseDownTime := nil.!
Item was added:
+ ScrollPane subclass: #SimpleHierarchicalListMorph
+ instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect columns sortingSelector getSelectionSelector setSelectionSelector potentialDropMorph lineColor'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
+ SimpleHierarchicalListMorph class
+ instanceVariableNames: 'expandedForm notExpandedForm'!
+
+ !SimpleHierarchicalListMorph commentStamp: 'ls 3/1/2004 12:15' prior: 0!
+ Display a hierarchical list of items. Each item should be wrapped with a ListItemWrapper.
+
+ For a simple example, look at submorphsExample. For beefier examples, look at ObjectExplorer or FileList2.!
+ SimpleHierarchicalListMorph class
+ instanceVariableNames: 'expandedForm notExpandedForm'!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph class>>expandedForm (in category 'instance creation') -----
+ expandedForm
+
+ expandedForm ifNotNil: [ expandedForm depth ~= Display depth ifTrue: [ expandedForm := nil ]].
+
+ ^expandedForm ifNil: [expandedForm :=
+ (Form
+ extent: 10 at 9
+ depth: 8
+ fromArray: #( 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760 4278255873 16843009 16842752 4294902089 1229539657 33488896 4294967041 1229539585 4294901760 4294967295 21561855 4294901760 4294967295 4278321151 4294901760 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760)
+ offset: 0 at 0)
+ asFormOfDepth: Display depth;
+ replaceColor: Color white withColor: Color transparent;
+ yourself
+ ].
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph class>>notExpandedForm (in category 'instance creation') -----
+ notExpandedForm
+
+ notExpandedForm ifNotNil: [ notExpandedForm depth ~= Display depth ifTrue: [ notExpandedForm := nil ]].
+
+ ^notExpandedForm ifNil: [notExpandedForm :=
+ (Form
+ extent: 10 at 9
+ depth: 8
+ fromArray: #( 4294967041 4294967295 4294901760 4294967041 33554431 4294901760 4294967041 1224867839 4294901760 4294967041 1229521407 4294901760 4294967041 1229539585 4294901760 4294967041 1229521407 4294901760 4294967041 1224867839 4294901760 4294967041 33554431 4294901760 4294967041 4294967295 4294901760)
+ offset: 0 at 0)
+ asFormOfDepth: Display depth;
+ replaceColor: Color white withColor: Color transparent;
+ yourself
+ ].
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph class>>on:list:selected:changeSelected: (in category 'instance creation') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel
+ "Create a 'pluggable' list view on the given model parameterized by the given message selectors."
+
+ ^ self new
+ on: anObject
+ list: getListSel
+ selected: getSelectionSel
+ changeSelected: setSelectionSel
+ menu: nil
+ keystroke: #arrowKey:from: "default"!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph class>>on:list:selected:changeSelected:menu: (in category 'instance creation') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel
+ "Create a 'pluggable' list view on the given model parameterized by the given message selectors."
+
+ ^ self new
+ on: anObject
+ list: getListSel
+ selected: getSelectionSel
+ changeSelected: setSelectionSel
+ menu: getMenuSel
+ keystroke: #arrowKey:from: "default"
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph class>>on:list:selected:changeSelected:menu:keystroke: (in category 'instance creation') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
+ "Create a 'pluggable' list view on the given model parameterized by the given message selectors."
+
+ ^ self new
+ on: anObject
+ list: getListSel
+ selected: getSelectionSel
+ changeSelected: setSelectionSel
+ menu: getMenuSel
+ keystroke: keyActionSel
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph class>>submorphsExample (in category 'examples') -----
+ submorphsExample
+ "display a hierarchical list of the World plus its submorphs plus its submorphs' submorphs etc."
+ "[SimpleHierarchicalListMorph submorphsExample]"
+ | morph |
+ morph :=
+ SimpleHierarchicalListMorph
+ on: [ Array with: (MorphWithSubmorphsWrapper with: World) ]
+ list: #value
+ selected: nil
+ changeSelected: nil
+ menu: nil
+ keystroke: nil.
+
+ morph openInWindow!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>acceptDroppingMorph:event: (in category 'dropping/grabbing') -----
+ acceptDroppingMorph: aMorph event: evt
+
+ self model
+ acceptDroppingMorph: aMorph
+ event: evt
+ inMorph: self.
+ self resetPotentialDropMorph.
+ evt hand releaseMouseFocus: self.
+ Cursor normal show.
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>addMorphsTo:from:allowSorting:withExpandedItems:atLevel: (in category 'private') -----
+ addMorphsTo: morphList from: aCollection allowSorting: sortBoolean withExpandedItems: expandedItems atLevel: newIndent
+
+ | priorMorph newCollection firstAddition |
+ priorMorph := nil.
+ newCollection := (sortBoolean and: [sortingSelector notNil]) ifTrue: [
+ (aCollection asSortedCollection: [ :a :b |
+ (a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection
+ ] ifFalse: [
+ aCollection
+ ].
+ firstAddition := nil.
+ newCollection do: [:item |
+ priorMorph := self indentingItemClass basicNew
+ initWithContents: item
+ prior: priorMorph
+ forList: self
+ indentLevel: newIndent.
+ firstAddition ifNil: [firstAddition := priorMorph].
+ morphList add: priorMorph.
+ ((item hasEquivalentIn: expandedItems) or: [priorMorph isExpanded]) ifTrue: [
+ priorMorph isExpanded: true.
+ priorMorph
+ addChildrenForList: self
+ addingTo: morphList
+ withExpandedItems: expandedItems.
+ ].
+ ].
+ ^firstAddition
+
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>addSubmorphsAfter:fromCollection:allowSorting: (in category 'private') -----
+ addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean
+
+ | priorMorph morphList newCollection |
+ priorMorph := nil.
+ newCollection := (sortBoolean and: [sortingSelector notNil]) ifTrue: [
+ (aCollection asSortedCollection: [ :a :b |
+ (a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection
+ ] ifFalse: [
+ aCollection
+ ].
+ morphList := OrderedCollection new.
+ newCollection do: [:item |
+ priorMorph := self indentingItemClass basicNew
+ initWithContents: item
+ prior: priorMorph
+ forList: self
+ indentLevel: parentMorph indentLevel + 1.
+ morphList add: priorMorph.
+ ].
+ scroller addAllMorphs: morphList after: parentMorph.
+ ^morphList
+
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>adjustSubmorphPositions (in category 'private') -----
+ adjustSubmorphPositions
+
+ | p |
+ p := 0 at 0.
+ scroller submorphsDo: [ :each | | h |
+ each visible ifTrue: [
+ h := each height.
+ each privateBounds: (p extent: 9999 at h).
+ p := p + (0 at h) ]].
+ self
+ changed;
+ layoutChanged;
+ setScrollDeltas.
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>arrowKey: (in category 'keyboard navigation') -----
+ arrowKey: asciiValue
+ "Handle a keyboard navigation character. Answer true if handled, false if not."
+ | keyEvent |
+ keyEvent := asciiValue.
+ keyEvent = 31 ifTrue:["down"
+ self setSelectionIndex: self getSelectionIndex+1.
+ ^true].
+ keyEvent = 30 ifTrue:["up"
+ self setSelectionIndex: (self getSelectionIndex-1 max: 1).
+ ^true].
+ keyEvent = 1 ifTrue: ["home"
+ self setSelectionIndex: 1.
+ ^true].
+ keyEvent = 4 ifTrue: ["end"
+ self setSelectionIndex: scroller submorphs size.
+ ^true].
+ keyEvent = 11 ifTrue: ["page up"
+ self setSelectionIndex: (self getSelectionIndex - self numSelectionsInView max: 1).
+ ^true].
+ keyEvent = 12 ifTrue: ["page down"
+ self setSelectionIndex: self getSelectionIndex + self numSelectionsInView.
+ ^true].
+ keyEvent = 29 ifTrue:["right"
+ selectedMorph ifNotNil:[
+ (selectedMorph canExpand and:[selectedMorph isExpanded not])
+ ifTrue:[self toggleExpandedState: selectedMorph]
+ ifFalse:[self setSelectionIndex: self getSelectionIndex+1].
+ ].
+ ^true].
+ keyEvent = 28 ifTrue:["left"
+ selectedMorph ifNotNil:[
+ (selectedMorph isExpanded)
+ ifTrue:[self toggleExpandedState: selectedMorph]
+ ifFalse:[self setSelectionIndex: (self getSelectionIndex-1 max: 1)].
+ ].
+ ^true].
+ ^false!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>autoDeselect: (in category 'initialization') -----
+ autoDeselect: trueOrFalse
+ "When selecting a selected item, it will be deselected. See #mouseUp:."
+
+ autoDeselect := trueOrFalse.!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>columns (in category 'accessing') -----
+ columns
+
+ ^columns!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>columns: (in category 'accessing') -----
+ columns: anArray
+ "You can specify columns or specs for columns. This depends on the actual morph that is used as item. ObjectExplorers produce items that support exact numbers, blocks, and nil for max width."
+
+ columns := anArray!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>currentlyExpanded (in category 'initialization') -----
+ currentlyExpanded
+
+ ^(scroller submorphs select: [ :each | each isExpanded]) collect: [ :each |
+ each complexContents
+ ].
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>drawLinesOn: (in category 'drawing') -----
+ drawLinesOn: aCanvas
+
+ | lColor |
+ lColor := self lineColor.
+ aCanvas
+ transformBy: scroller transform
+ clippingTo: scroller innerBounds
+ during:[:clippedCanvas |
+ scroller submorphs
+ select: [:submorph | submorph visible]
+ thenDo: [ :submorph |
+ ((submorph isExpanded
+ or: [clippedCanvas isVisible: submorph fullBounds] )
+ or: [ submorph nextSibling notNil and: [clippedCanvas isVisible: submorph nextSibling]])
+ ifTrue: [submorph drawLinesOn: clippedCanvas lineColor: lColor] ] ]
+ smoothing: scroller smoothing.
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ super drawOn: aCanvas.
+ selectedMorph
+ ifNotNil: [aCanvas
+ fillRectangle: (((scroller transformFrom: self)
+ invertBoundsRect: selectedMorph bounds)
+ intersect: scroller bounds)
+ color: Preferences menuSelectionColor].
+ self drawLinesOn: aCanvas!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>expand:to: (in category 'events') -----
+ expand: aMorph to: level
+ | allChildren |
+ aMorph toggleExpandedState.
+ allChildren := OrderedCollection new: 10.
+ aMorph recursiveAddTo: allChildren.
+ allChildren do: [:each |
+ ((each canExpand
+ and: [each isExpanded not])
+ and: [level > 0])
+ ifTrue: [self expand: each to: level-1]].!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>expandAll (in category 'events') -----
+ expandAll
+ (selectedMorph isNil
+ or: [selectedMorph isExpanded])
+ ifTrue: [^self].
+ self expandAll: selectedMorph.
+ self adjustSubmorphPositions!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>expandAll: (in category 'events') -----
+ expandAll: aMorph
+ | allChildren |
+ aMorph toggleExpandedState.
+ allChildren := OrderedCollection new: 10.
+ aMorph recursiveAddTo: allChildren.
+ allChildren do: [:each |
+ (each canExpand and: [each isExpanded not])
+ ifTrue: [self expandAll: each]].
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>expandAll:except: (in category 'events') -----
+ expandAll: aMorph except: aBlock
+ | allChildren |
+ (aBlock value: aMorph complexContents)
+ ifFalse: [^self].
+ aMorph toggleExpandedState.
+ allChildren := OrderedCollection new: 10.
+ aMorph recursiveAddTo: allChildren.
+ allChildren do: [:each |
+ (each canExpand
+ and: [each isExpanded not])
+ ifTrue: [self expandAll: each except: aBlock]].!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>expandRoots (in category 'events') -----
+ expandRoots
+ "Expand all the receiver's roots"
+ self roots
+ do: [:each |
+ (each canExpand and: [each isExpanded not])
+ ifTrue: [each toggleExpandedState]].
+ self adjustSubmorphPositions!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>expandedForm (in category 'drawing') -----
+ expandedForm
+
+ ^self class expandedForm!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>extent: (in category 'geometry') -----
+ extent: newExtent
+ bounds extent = newExtent ifTrue: [^ self].
+ super extent: newExtent.
+ self setScrollDeltas !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>getCurrentSelectionItem (in category 'selection') -----
+ getCurrentSelectionItem
+
+ ^model perform: (getSelectionSelector ifNil: [^nil])
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>getList (in category 'model access') -----
+ getList
+ "Answer the list to be displayed."
+
+ ^(model perform: (getListSelector ifNil: [^#()])) ifNil: [#()]
+
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>getSelectionIndex (in category 'keyboard navigation') -----
+ getSelectionIndex
+ ^scroller submorphs indexOf: selectedMorph!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>hExtraScrollRange (in category 'scrolling') -----
+ hExtraScrollRange
+ "Return the amount of extra blank space to include below the bottom of the scroll content."
+ ^5
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>hUnadjustedScrollRange (in category 'scrolling') -----
+ hUnadjustedScrollRange
+ "Return the width of the widest item in the list"
+
+ | max count |
+
+ max := 0.
+ count := 0.
+ scroller submorphsDo: [ :each | | stringW right |
+ stringW := each font widthOfStringOrText: each contents.
+ right := (each toggleRectangle right + stringW + 10).
+ max := max max: right.
+
+ "NOTE: need to optimize this method by caching list item morph widths (can init that cache most efficiently in the #list: method before the item widths are reset to 9999). For now, just punt on really long lists"
+ ((count := count + 1) > 200) ifTrue:[ ^max * 3].
+ ].
+
+ ^max
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>handleMouseMove: (in category 'events-processing') -----
+ handleMouseMove: anEvent
+ "Reimplemented because we really want #mouseMove when a morph is dragged around"
+ anEvent wasHandled ifTrue:[^self]. "not interested"
+ (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
+ anEvent wasHandled: true.
+ self mouseMove: anEvent.
+ (self handlesMouseStillDown: anEvent) ifTrue:[
+ "Step at the new location"
+ self startStepping: #handleMouseStillDown:
+ at: Time millisecondClockValue
+ arguments: {anEvent copy resetHandlerFields}
+ stepTime: 1].
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>handlesMouseOverDragging: (in category 'event handling') -----
+ handlesMouseOverDragging: evt
+ ^self dropEnabled!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>highlightSelection (in category 'drawing') -----
+ highlightSelection
+
+ selectedMorph ifNotNil: [selectedMorph highlight]!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>indentingItemClass (in category 'initialization') -----
+ indentingItemClass
+
+ ^IndentingListItemMorph!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ self
+ on: #mouseMove
+ send: #mouseStillDown:onItem:
+ to: self!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>insertNewMorphs: (in category 'private') -----
+ insertNewMorphs: morphList
+
+ scroller addAllMorphs: morphList.
+ self adjustSubmorphPositions.
+ self selection: self getCurrentSelectionItem.
+ self setScrollDeltas.
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>installModelIn: (in category 'debug and other') -----
+ installModelIn: aWorld
+ "No special inits for new components"
+ ^ self!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>itemFromPoint: (in category 'event handling') -----
+ itemFromPoint: aPoint
+ "Return the list element (morph) at the given point or nil if outside"
+ | ptY visibleRows |
+ scroller hasSubmorphs ifFalse:[^nil].
+ (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil].
+
+ visibleRows := scroller submorphs select: [:m | m visible].
+
+ ptY := (visibleRows first point: aPoint from: self) y.
+ "note: following assumes that submorphs are vertical, non-overlapping, and ordered"
+ visibleRows first top > ptY ifTrue:[^nil].
+ visibleRows last bottom < ptY ifTrue:[^nil].
+ "now use binary search"
+ ^visibleRows
+ findBinary:[:item|
+ (item top <= ptY and:[item bottom >= ptY])
+ ifTrue:[0] "found"
+ ifFalse:[ (item top + item bottom // 2) > ptY ifTrue:[-1] ifFalse:[1]]]
+ ifNone: [nil]!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>keyStroke: (in category 'event handling') -----
+ keyStroke: event
+ "Process potential command keys"
+
+ (self scrollByKeyboard: event) ifTrue: [^ true].
+
+ event keyCharacter asciiValue < 32 ifTrue: [
+ ^ self specialKeyPressed: event keyCharacter asciiValue].
+
+ (self keyStrokeAction: event) ifTrue: [^ true].
+
+ ^ false!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>keyStrokeAction: (in category 'event handling') -----
+ keyStrokeAction: event
+
+ | numArgs |
+ keystrokeActionSelector ifNil: [^false].
+
+ numArgs := keystrokeActionSelector numArgs.
+
+ numArgs = 1 ifTrue: [
+ ^ model
+ perform: keystrokeActionSelector
+ with: event keyCharacter].
+ numArgs = 2 ifTrue: [
+ ^ model
+ perform: keystrokeActionSelector
+ with: event keyCharacter
+ with: self].
+ numArgs = 3 ifTrue: [
+ ^ model
+ perform: keystrokeActionSelector
+ with: event keyCharacter
+ with: self
+ with: event].
+ ^self error: 'The keystrokeActionSelector must be a 1-, 2-, or 3-keyword symbol'!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>lineColor (in category 'accessing') -----
+ lineColor
+ "Answer a good color to use for drawing the lines that connect members of the hierarchy view.
+ Used the cached color, or derive it if necessary by finding the first owner (up to my root) that is not transparent, then picking a contrasting color.
+ Fall back to veryLightGray if all my owners are transparent."
+
+ | coloredOwner targetLuminance ownerColor darken |
+ lineColor ifNotNil: [ ^lineColor ].
+ coloredOwner := self firstOwnerSuchThat: [ :o | o isWorldOrHandMorph not and: [ o color isTransparent not ]].
+ coloredOwner ifNil: [ ^Color veryLightGray ].
+ ownerColor := coloredOwner color.
+ darken := ownerColor luminance > 0.5.
+ targetLuminance := ownerColor luminance + (darken ifTrue: [ -0.2 ] ifFalse: [ 0.2 ]).
+ ^darken
+ ifTrue: [ ownerColor atMostAsLuminentAs: targetLuminance ]
+ ifFalse: [ ownerColor atLeastAsLuminentAs: targetLuminance ]
+
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>lineColor: (in category 'accessing') -----
+ lineColor: aColor
+ ^lineColor := aColor
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>list: (in category 'initialization') -----
+ list: aCollection
+
+ | wereExpanded morphList |
+ wereExpanded := self currentlyExpanded.
+ scroller removeAllMorphs.
+ (aCollection isNil or: [aCollection isEmpty]) ifTrue: [^ self selectedMorph: nil].
+ morphList := OrderedCollection new.
+ self
+ addMorphsTo: morphList
+ from: aCollection
+ allowSorting: false
+ withExpandedItems: wereExpanded
+ atLevel: 0.
+ self insertNewMorphs: morphList.!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>listItemHeight (in category 'initialization') -----
+ listItemHeight
+ "This should be cleaned up. The list should get spaced by this parameter."
+ ^ 12!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>maximumSelection (in category 'selection') -----
+ maximumSelection
+
+ ^ scroller submorphs size
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>minimumSelection (in category 'selection') -----
+ minimumSelection
+ ^ 1!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ | aMorph selectors |
+ aMorph := self itemFromPoint: evt position.
+ evt yellowButtonPressed "First check for option (menu) click"
+ ifTrue: [
+ (PluggableListMorph menuRequestUpdatesSelection and: [model okToChange]) ifTrue: [
+ aMorph == selectedMorph
+ ifFalse: [self setSelectedMorph: aMorph]].
+ ^ self yellowButtonActivity: evt shiftPressed].
+ (aMorph notNil and:[aMorph inToggleArea: (aMorph point: evt position from: self)])
+ ifTrue:[^self toggleExpandedState: aMorph event: evt].
+ aMorph ifNil:[^super mouseDown: evt].
+ aMorph highlightForMouseDown.
+ selectors := Array
+ with: #click:
+ with: nil
+ with: nil
+ with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]).
+ evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: HandMorph dragThreshold "pixels".!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseDown:onItem: (in category 'obsolete') -----
+ mouseDown: event onItem: aMorph
+ self removeObsoleteEventHandlers.
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseEnter: (in category 'event handling') -----
+ mouseEnter: event
+ super mouseEnter: event.
+ event hand newKeyboardFocus: self!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseEnterDragging: (in category 'event handling') -----
+ mouseEnterDragging: evt
+ | aMorph |
+ (evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d"
+ ^super mouseEnterDragging: evt].
+ (self wantsDroppedMorph: evt hand firstSubmorph event: evt )
+ ifTrue:[
+ aMorph := self itemFromPoint: evt position.
+ aMorph ifNotNil:[self potentialDropMorph: aMorph].
+ evt hand newMouseFocus: self.
+ "above is ugly but necessary for now"
+ ].!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseEnterDragging:onItem: (in category 'obsolete') -----
+ mouseEnterDragging: anEvent onItem: aMorph
+ self removeObsoleteEventHandlers.!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseLeave: (in category 'event handling') -----
+ mouseLeave: aMouseEvent
+ super mouseLeave: aMouseEvent.
+ Preferences mouseOverForKeyboardFocus ifTrue: [ aMouseEvent hand releaseKeyboardFocus: self ]!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseLeaveDragging: (in category 'event handling') -----
+ mouseLeaveDragging: anEvent
+ (self dropEnabled and:[anEvent hand hasSubmorphs]) ifFalse: ["no d&d"
+ ^ super mouseLeaveDragging: anEvent].
+ self resetPotentialDropMorph.
+ anEvent hand releaseMouseFocus: self.
+ "above is ugly but necessary for now"
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseLeaveDragging:onItem: (in category 'obsolete') -----
+ mouseLeaveDragging: anEvent onItem: aMorph
+ self removeObsoleteEventHandlers.!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+
+ (self dropEnabled and:[evt hand hasSubmorphs])
+ ifFalse:[^super mouseMove: evt].
+ potentialDropMorph ifNotNil:[
+ (potentialDropMorph containsPoint: (potentialDropMorph point: evt position from: self))
+ ifTrue:[^self].
+ ].
+ self mouseLeaveDragging: evt.
+ (self containsPoint: evt position)
+ ifTrue:[self mouseEnterDragging: evt].!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: event
+ | aMorph |
+ aMorph := self itemFromPoint: event position.
+ aMorph ifNil: [^self].
+ aMorph highlightedForMouseDown ifFalse: [^self].
+ aMorph highlightForMouseDown: false.
+ model okToChange ifFalse: [^self].
+ "No change if model is locked"
+ ((autoDeselect isNil or: [autoDeselect]) and: [aMorph == selectedMorph])
+ ifTrue: [self setSelectedMorph: nil]
+ ifFalse: [self setSelectedMorph: aMorph].
+ event hand newKeyboardFocus: self.
+ Cursor normal show!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>notExpandedForm (in category 'drawing') -----
+ notExpandedForm
+
+ ^self class notExpandedForm!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>noteRemovalOfAll: (in category 'private') -----
+ noteRemovalOfAll: aCollection
+
+ scroller removeAllMorphsIn: aCollection.
+ (aCollection includes: selectedMorph) ifTrue: [self setSelectedMorph: nil].!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>on:list:selected:changeSelected:menu:keystroke: (in category 'initialization') -----
+ on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
+
+ self model: anObject.
+ getListSelector := getListSel.
+ getSelectionSelector := getSelectionSel.
+ setSelectionSelector := setSelectionSel.
+ getMenuSelector := getMenuSel.
+ keystrokeActionSelector := keyActionSel.
+ autoDeselect := true.
+ self borderWidth: 1.
+ self list: self getList.!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>potentialDropMorph (in category 'dropping/grabbing') -----
+ potentialDropMorph
+ ^potentialDropMorph!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>potentialDropMorph: (in category 'dropping/grabbing') -----
+ potentialDropMorph: aMorph
+ potentialDropMorph := aMorph.
+ aMorph highlightForDrop!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>removeObsoleteEventHandlers (in category 'obsolete') -----
+ removeObsoleteEventHandlers
+ scroller submorphs do:[:m|
+ m eventHandler: nil; highlightForMouseDown: false; resetExtension].!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>resetPotentialDropMorph (in category 'dropping/grabbing') -----
+ resetPotentialDropMorph
+ potentialDropMorph ifNotNil: [
+ potentialDropMorph resetHighlightForDrop.
+ potentialDropMorph := nil]
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>roots (in category 'accessing') -----
+ roots
+ "Answer the receiver's roots"
+ ^ scroller submorphs
+ select: [:each | each indentLevel isZero]!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>scrollDeltaHeight (in category 'geometry') -----
+ scrollDeltaHeight
+ ^ scroller hasSubmorphs
+ ifTrue: [scroller firstSubmorph height]
+ ifFalse: [super scrollDeltaHeight]!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>scrollDeltaWidth (in category 'geometry') -----
+ scrollDeltaWidth
+ "A guess -- assume that the width of a char is approx 1/2 the height of the font"
+ ^ self scrollDeltaHeight // 2
+
+
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>selectedMorph (in category 'selection') -----
+ selectedMorph
+ ^selectedMorph!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>selectedMorph: (in category 'selection') -----
+ selectedMorph: aMorph
+
+ self unhighlightSelection.
+ selectedMorph := aMorph.
+ self highlightSelection!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>selection: (in category 'selection') -----
+ selection: item
+ "Called from outside to request setting a new selection.
+ Assumes scroller submorphs is exactly our list.
+ Note: MAY NOT work right if list includes repeated items"
+
+ | i |
+ item ifNil: [^self selectionIndex: 0].
+ i := scroller submorphs findFirst: [:m | m complexContents == item].
+ i > 0 ifTrue: [^self selectionIndex: i].
+ i := scroller submorphs findFirst: [:m | m withoutListWrapper = item withoutListWrapper].
+ self selectionIndex: i!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>selectionIndex: (in category 'selection') -----
+ selectionIndex: idx
+ "Called internally to select the index-th item."
+ | theMorph index |
+ idx ifNil: [^ self].
+ index := idx min: scroller submorphs size max: 0.
+ (theMorph := index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index])
+ ifNotNil: [self scrollToShow: theMorph bounds].
+ self selectedMorph: theMorph!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>selectionOneOf: (in category 'selection') -----
+ selectionOneOf: aListOfItems
+ "Set the selection to the first item in the list which is represented by one of my submorphs"
+
+
+ aListOfItems do: [ :item | | index |
+ index := scroller submorphs findFirst: [:m |
+ m withoutListWrapper = item withoutListWrapper
+ ].
+ index > 0 ifTrue: [^self selectionIndex: index].
+ ].
+ self selectionIndex: 0.!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>setSelectedMorph: (in category 'selection') -----
+ setSelectedMorph: aMorph
+
+ model
+ perform: (setSelectionSelector ifNil: [^self])
+ with: aMorph complexContents "leave last wrapper in place"
+
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>setSelectionIndex: (in category 'keyboard navigation') -----
+ setSelectionIndex: idx
+ "Called internally to select the index-th item."
+ | theMorph index max currentIndex |
+ idx ifNil: [^ self].
+ max := scroller submorphs size.
+ currentIndex := self getSelectionIndex.
+
+ index := idx min: max max: 0.
+ theMorph := index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index].
+
+ "Skip invisible rows."
+ [theMorph notNil and: [theMorph visible not]] whileTrue: [
+ currentIndex < index
+ ifTrue: [index := index + 1]
+ ifFalse: [index := index - 1].
+ (index < 1 or: [index > max]) ifTrue: [^ self].
+ theMorph := scroller submorphs at: index.
+ ].
+ self setSelectedMorph: theMorph.!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>sortingSelector: (in category 'accessing') -----
+ sortingSelector: s
+
+ sortingSelector := s!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>specialKeyPressed: (in category 'event handling') -----
+ specialKeyPressed: asciiValue
+
+ ^ self arrowKey: asciiValue!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>startDrag: (in category 'event handling') -----
+ startDrag: evt
+ | ddm itemMorph passenger |
+ self dragEnabled
+ ifTrue: [itemMorph := scroller submorphs
+ detect: [:any | any highlightedForMouseDown]
+ ifNone: []].
+ (itemMorph isNil
+ or: [evt hand hasSubmorphs])
+ ifTrue: [^ self].
+ itemMorph highlightForMouseDown: false.
+ itemMorph ~= self selectedMorph
+ ifTrue: [self setSelectedMorph: itemMorph].
+ passenger := self model dragPassengerFor: itemMorph inMorph: self.
+ passenger
+ ifNotNil: [ddm := TransferMorph withPassenger: passenger from: self.
+ ddm
+ dragTransferType: (self model dragTransferTypeForMorph: self).
+ Preferences dragNDropWithAnimation
+ ifTrue: [self model dragAnimationFor: itemMorph transferMorph: ddm].
+ evt hand grabMorph: ddm].
+ evt hand releaseMouseFocus: self!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>startDrag:onItem: (in category 'obsolete') -----
+ startDrag: evt onItem: itemMorph
+ self removeObsoleteEventHandlers.!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>toggleExpandedState: (in category 'keyboard navigation') -----
+ toggleExpandedState: aMorph
+ aMorph toggleExpandedState.
+ self adjustSubmorphPositions.
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>toggleExpandedState:event: (in category 'events') -----
+ toggleExpandedState: aMorph event: event
+ | oldState |
+ "self setSelectedMorph: aMorph."
+ event yellowButtonPressed ifTrue: [
+ oldState := aMorph isExpanded.
+ scroller submorphs copy do: [ :each |
+ (each canExpand and: [each isExpanded = oldState]) ifTrue: [
+ each toggleExpandedState.
+ ].
+ ].
+ ] ifFalse: [
+ aMorph toggleExpandedState.
+ ].
+ self adjustSubmorphPositions.
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>unhighlightSelection (in category 'drawing') -----
+ unhighlightSelection
+ selectedMorph ifNotNil: [selectedMorph unhighlight]!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>update: (in category 'updating') -----
+ update: aSymbol
+ aSymbol == getSelectionSelector
+ ifTrue:
+ [self selection: self getCurrentSelectionItem.
+ ^self].
+ aSymbol == getListSelector
+ ifTrue:
+ [self list: self getList.
+ ^self].
+ ((aSymbol isKindOf: Array)
+ and: [aSymbol notEmpty and: [aSymbol first == #openPath]])
+ ifTrue:
+ [^(scroller submorphs at: 1 ifAbsent: [^self])
+ openPath: aSymbol allButFirst]!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>vUnadjustedScrollRange (in category 'scrolling') -----
+ vUnadjustedScrollRange
+ "Return the width of the widest item in the list"
+
+ (scroller submorphs size > 0) ifFalse:[ ^0 ].
+ ^scroller submorphs last fullBounds bottom
+ !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
+ wantsDroppedMorph: aMorph event: anEvent
+ ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self!
Item was added:
+ Morph subclass: #SketchMorph
+ instanceVariableNames: 'originalForm rotationStyle scalePoint framesToDwell rotatedForm keepAspectRatio'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !SketchMorph commentStamp: '<historical>' prior: 0!
+ The morph that results when the user draws a color bitmap using the PaintBox (SketchEditorMorph and PaintBoxMorph).
+
+ forwardDirection is the angle at which the object will go forward. When the rotationStyle is not #normal, then forwardDirection is any angle, while the rotation is highly restricted. If flexed, this is remembered by the Transform morph. For non-normal rotationStyle, it is rotationDegrees.
+
+ setupAngle (a property) is where the user put the green arrow to indicate which direction on the picture is forward. When #normal, draw the morph initially at (0.0 - setupAngle). The enclosing TransformationMorph then rotates it to the true angle.
+
+ rotationDegrees In a #normal object, rotationDegrees is constant an equal to setupAngle.
+ For non-normal, it is the direction the object is going.
+
+ When repainting, set it back to its original state. The green arrow is set to setupAngle, and the sketch is shown as drawn originally (rotationDegrees = 0).
+
+ rotationStyle = normal (turns), leftRight, upDown, fixed.
+ When leftRight upDown or fixed, bit map has severe restrictions.
+ !
Item was added:
+ ----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') -----
+ defaultNameStemForInstances
+ ^ 'Sketch'!
Item was added:
+ ----- Method: SketchMorph class>>fromFile: (in category 'instance creation') -----
+ fromFile: aFileName
+ ^self fromStream: (FileStream readOnlyFileNamed: aFileName)!
Item was added:
+ ----- Method: SketchMorph class>>fromStream: (in category 'instance creation') -----
+ fromStream: aStream
+ ^self withForm: (ImageReadWriter formFromStream: aStream)!
Item was added:
+ ----- Method: SketchMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ "Not to be instantiated from the menu"
+ ^ false!
Item was added:
+ ----- Method: SketchMorph class>>isSketchMorphClass (in category 'testing') -----
+ isSketchMorphClass
+ ^true!
Item was added:
+ ----- Method: SketchMorph class>>openEditor (in category 'instance creation') -----
+ openEditor
+ "Create a new SketchMorph and open a SketchMorphEditor on it.
+ Answers the painted SketchMorph."
+ "SketchMorph openEditor"
+ | newSketch |
+ newSketch := (self
+ withForm: (Form extent: 100 @ 100 depth: Display depth)) center: self currentWorld center;
+ openInWorld;
+ editDrawing.
+ ^ newSketch!
Item was added:
+ ----- Method: SketchMorph class>>withForm: (in category 'instance creation') -----
+ withForm: aForm
+ "Note: 'SketchMorph withForm: zz' is MUCH faster
+ than 'SketchMorph new form: zz'."
+
+ ^ self basicNew initializeWith: aForm!
Item was added:
+ ----- Method: SketchMorph>>addBorderToShape: (in category 'menu') -----
+ addBorderToShape: evt
+ | str borderWidth borderedForm r |
+ str := UIManager default
+ request: 'Please enter the desired border width' translated
+ initialAnswer: '0'.
+ borderWidth := Integer readFrom: (ReadStream on: str).
+ (borderWidth between: 1 and: 10) ifFalse: [^ self].
+
+ "Take care of growing appropriately. Does this lose the reg point?"
+ borderedForm := originalForm shapeBorder: Color black width: borderWidth.
+ r := borderedForm rectangleEnclosingPixelsNotOfColor: Color transparent.
+ self form: (borderedForm copy: r).
+ !
Item was added:
+ ----- Method: SketchMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ "Add custom menu items"
+
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu add: 'restore base graphic' translated target: self action: #restoreBaseGraphicFromMenu.
+ aCustomMenu add: 'call this my base graphic' translated target: self action: #callThisBaseGraphic.
+ aCustomMenu add: 'choose new graphic...' translated target: self action: #chooseNewGraphic.
+ aCustomMenu addLine.
+ aCustomMenu add: 'set as background' translated target: rotatedForm action: #setAsBackground.
+ self addPaintingItemsTo: aCustomMenu hand: aHandMorph!
Item was added:
+ ----- Method: SketchMorph>>addFillStyleMenuItems:hand: (in category 'menus') -----
+ addFillStyleMenuItems: aMenu hand: aHand
+ "Do nothing here - we do not allow changing the fill style of a SketchMorph yet."!
Item was added:
+ ----- Method: SketchMorph>>addToggleItemsToHaloMenu: (in category 'menus') -----
+ addToggleItemsToHaloMenu: aCustomMenu
+ "Add toggle-items to the halo menu"
+ super addToggleItemsToHaloMenu: aCustomMenu.
+ Preferences noviceMode
+ ifFalse: [""aCustomMenu
+ addUpdating: #useInterpolationString
+ target: self
+ action: #toggleInterpolation]!
Item was added:
+ ----- Method: SketchMorph>>baseGraphic (in category 'e-toy support') -----
+ baseGraphic
+ "Answer my base graphic"
+
+ ^ self valueOfProperty: #baseGraphic ifAbsent:
+ [self setProperty: #baseGraphic toValue: originalForm.
+ ^ originalForm]!
Item was added:
+ ----- Method: SketchMorph>>baseGraphic: (in category 'e-toy support') -----
+ baseGraphic: aForm
+ "Remember the given form as the receiver's base graphic"
+
+ ^ self setProperty: #baseGraphic toValue: aForm!
Item was added:
+ ----- Method: SketchMorph>>callThisBaseGraphic (in category 'menu') -----
+ callThisBaseGraphic
+ "Set my baseGraphic to be the current form"
+
+ | aGraphic |
+ self isInWorld ifFalse: [^ self inform:
+
+ 'oops, this menu is a for a morph that
+ has been replaced, probably because a
+ "look like" script was run. Please dismiss
+ the menu and get a new one!!. Sorry!!' translated].
+
+ ((aGraphic := self valueOfProperty: #baseGraphic)
+ notNil and: [aGraphic ~= originalForm])
+ ifTrue:
+ [self setProperty: #baseGraphic toValue: originalForm]
+ ifFalse:
+ [self inform: 'this already *was* your baseGraphic' translated]!
Item was added:
+ ----- Method: SketchMorph>>canBeEnlargedWithB3D (in category 'drawing') -----
+ canBeEnlargedWithB3D
+ ^self
+ valueOfProperty: #canBeEnlargedWithB3D
+ ifAbsent: [
+ | answer |
+ answer := self rotatedForm colorsUsed allSatisfy: [ :c | c isTranslucent not].
+ self setProperty: #canBeEnlargedWithB3D toValue: answer.
+ answer
+ ]!
Item was added:
+ ----- Method: SketchMorph>>changePixelsOfColor:toColor: (in category 'menus') -----
+ changePixelsOfColor: c toColor: newColor
+
+ | r |
+ originalForm mapColor: c to: newColor.
+ r := originalForm rectangleEnclosingPixelsNotOfColor: Color transparent.
+ self form: (originalForm copy: r).
+
+ !
Item was added:
+ ----- Method: SketchMorph>>clearExtent:fillColor: (in category 'pen support') -----
+ clearExtent: aPoint fillColor: aColor
+ "Make this sketch have the given pixel dimensions and fill it with given color. Its previous contents are replaced."
+
+ self form:
+ ((Form extent: aPoint depth: Display depth) fillColor: aColor).
+ !
Item was added:
+ ----- Method: SketchMorph>>collapse (in category 'menus') -----
+ collapse
+
+ | priorPosition w collapsedVersion a |
+
+ (w := self world) ifNil: [^self].
+ collapsedVersion := (self imageForm scaledToSize: 50 at 50) asMorph.
+ collapsedVersion setProperty: #uncollapsedMorph toValue: self.
+ collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
+ collapsedVersion setBalloonText: 'A collapsed version of ',self name.
+
+ self delete.
+ w addMorphFront: (
+ a := AlignmentMorph newRow
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ borderWidth: 4;
+ borderColor: Color white;
+ addMorph: collapsedVersion
+ ).
+ collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+
+ (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil])
+ ifNotNil:
+ [a position: priorPosition].
+ !
Item was added:
+ ----- Method: SketchMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+
+ ^ (self bounds containsPoint: aPoint) and:
+ [(self rotatedForm isTransparentAt: aPoint - bounds origin) not]
+ !
Item was added:
+ ----- Method: SketchMorph>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ scalePoint ifNil: [scalePoint := 1.0 at 1.0].
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: SketchMorph>>drawHighResolutionOn:in: (in category 'drawing') -----
+ drawHighResolutionOn: aCanvas in: aRectangle
+
+ | r finalClipRect scale sourceOrigin sourceExtent sourceRect biggerSource biggerDestExtent interForm offsetInBigger |
+
+ r := aRectangle translateBy: aCanvas origin.
+ finalClipRect := r intersect: (aCanvas clipRect translateBy: aCanvas origin).
+ self canBeEnlargedWithB3D ifTrue: [
+ (WarpBlt toForm: aCanvas form)
+ clipRect: finalClipRect;
+ sourceForm: originalForm;
+ cellSize: 2; "installs a colormap"
+ combinationRule: Form paint;
+
+ copyQuad: originalForm boundingBox innerCorners
+ toRect: r.
+ ^self
+ ].
+ scale := aRectangle extent / originalForm extent.
+ sourceOrigin := originalForm offset + (aCanvas clipRect origin - aRectangle origin / scale).
+ sourceExtent := aCanvas clipRect extent / scale.
+ sourceRect := sourceOrigin rounded extent: sourceExtent rounded.
+ biggerSource := sourceRect expandBy: 1.
+ biggerDestExtent := (biggerSource extent * scale) rounded.
+ offsetInBigger := (sourceOrigin - biggerSource origin * scale) rounded.
+
+ interForm := Form extent: biggerDestExtent depth: aCanvas depth.
+ (originalForm copy: biggerSource)
+ displayInterpolatedIn: interForm boundingBox
+ on: interForm.
+ aCanvas
+ drawImage: interForm
+ at: aCanvas clipRect origin
+ sourceRect: (offsetInBigger extent: aCanvas clipRect extent).
+
+
+ !
Item was added:
+ ----- Method: SketchMorph>>drawInterpolatedImage:on: (in category 'drawing') -----
+ drawInterpolatedImage: aForm on: aCanvas
+ "Draw the given form onto the canvas using the Balloon 3D engine"
+ | engine |
+ engine := Smalltalk at: #B3DRenderEngine
+ ifPresent:[:b3d | b3d defaultForPlatformOn: aCanvas form].
+ engine == nil ifTrue:[
+ self useInterpolation: false.
+ ^self generateRotatedForm].
+ "Setup the engine"
+ engine viewport: aCanvas form boundingBox.
+ "Install the material to be used (using a plain white emission color)"
+ engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white).
+ "Install the texture"
+ engine texture: aForm.
+ "Draw the mesh"
+ engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect).
+ "and finish"
+ engine finish.!
Item was added:
+ ----- Method: SketchMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ aCanvas translucentImage: self rotatedForm at: bounds origin
+ !
Item was added:
+ ----- Method: SketchMorph>>editDrawing (in category 'menu') -----
+ editDrawing
+ self flag: #deferred. "Don't allow this if the user is already in paint mode, because it creates a very strange situation."
+ "costumee ifNotNil: [self forwardDirection: costumee direction]." "how say this?"
+ self editDrawingIn: self pasteUpMorph forBackground: false
+ !
Item was added:
+ ----- Method: SketchMorph>>editDrawingIn:forBackground: (in category 'menu') -----
+ editDrawingIn: aPasteUpMorph forBackground: forBackground
+ "Edit an existing sketch."
+
+ | w bnds sketchEditor rotCenter aPaintTab aWorld aPaintBox |
+ self world assureNotPaintingElse: [^self].
+ w := aPasteUpMorph world.
+ w prepareToPaint.
+ w displayWorld.
+ self visible: false.
+ bnds := forBackground
+ ifTrue: [aPasteUpMorph boundsInWorld]
+ ifFalse:
+ [bnds := self boundsInWorld expandBy: 60 @ 60.
+ (aPasteUpMorph paintingBoundsAround: bnds center) merge: bnds].
+ sketchEditor := SketchEditorMorph new.
+ forBackground
+ ifTrue: [sketchEditor setProperty: #background toValue: true].
+ w addMorphFront: sketchEditor.
+ sketchEditor
+ initializeFor: self
+ inBounds: bnds
+ pasteUpMorph: aPasteUpMorph.
+ rotCenter := self rotationCenter.
+
+ sketchEditor afterNewPicDo:
+ [:aForm :aRect | | tfx |
+ self visible: true.
+ self form: aForm.
+ tfx := aPasteUpMorph transformFrom: aPasteUpMorph world.
+ self topRendererOrSelf position: (tfx globalPointToLocal: aRect origin).
+ self rotationStyle: sketchEditor rotationStyle.
+ self forwardDirection: sketchEditor forwardDirection.
+ (rotCenter notNil and: [(rotCenter = (0.5 @ 0.5)) not]) ifTrue:
+ [self rotationCenter: rotCenter].
+ (aPaintTab := (aWorld := self world) paintingFlapTab)
+ ifNotNil: [aPaintTab hideFlap]
+ ifNil: [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete]].
+ self presenter drawingJustCompleted: self.
+
+ forBackground ifTrue: [self goBehind "shouldn't be necessary"]]
+ ifNoBits:
+ [ | pal |"If no bits drawn. Must keep old pic. Can't have no picture"
+
+ self visible: true.
+ aWorld := self currentWorld.
+ "sometimes by now I'm no longer in a world myself, but we still need
+ to get ahold of the world so that we can deal with the palette"
+ ((pal := aPasteUpMorph standardPalette) notNil and: [pal isInWorld])
+ ifTrue:
+ [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete].
+ pal viewMorph: self]
+ ifFalse:
+ [(aPaintTab := (aWorld := self world) paintingFlapTab)
+ ifNotNil: [aPaintTab hideFlap]
+ ifNil: [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete]]]]!
Item was added:
+ ----- Method: SketchMorph>>erasePixelsOfColor: (in category 'menu') -----
+ erasePixelsOfColor: aColor
+ "Let the user specifiy a color such that all pixels of that color should be erased; then do the erasure"
+ | newBounds |
+ originalForm
+ mapColor: aColor
+ to: Color transparent.
+ newBounds := originalForm rectangleEnclosingPixelsNotOfColor: Color transparent.
+ self form: (originalForm copy: newBounds)!
Item was added:
+ ----- Method: SketchMorph>>erasePixelsUsing: (in category 'menu') -----
+ erasePixelsUsing: evt
+ "Let the user specifiy a color such that all pixels of that color should be erased; then do the erasure"
+ self
+ changeColorTarget: self
+ selector: #rememberedColor:
+ originalColor: nil
+ hand: evt hand.
+ self rememberedColor "color to erase"
+ ifNil: [ ^ self ]
+ ifNotNilDo:
+ [ : chosenColor | self erasePixelsOfColor: chosenColor ]!
Item was added:
+ ----- Method: SketchMorph>>extent: (in category 'geometry') -----
+ extent: newExtent
+ "Change my scale to fit myself into the given extent.
+ Avoid extents where X or Y is zero."
+
+ newExtent isZero ifTrue: [ ^self ].
+ self extent = newExtent ifTrue:[^self].
+ self scalePoint: newExtent asFloatPoint / (originalForm extent max: 1 at 1).
+ self layoutChanged.
+ !
Item was added:
+ ----- Method: SketchMorph>>firstIntersectionWithLineFrom:to: (in category 'geometry') -----
+ firstIntersectionWithLineFrom: start to: end
+ | intersections last |
+ intersections := self fullBounds extrapolatedIntersectionsWithLineFrom: start to: end.
+ intersections size = 1 ifTrue: [ ^intersections anyOne ].
+ intersections isEmpty ifTrue: [ ^nil ].
+ intersections := intersections asSortedCollection: [ :a :b | (start dist: a) < (start dist: b) ].
+ last := intersections first rounded.
+ last pointsTo: intersections last rounded do: [ :pt |
+ (self rotatedForm isTransparentAt: (pt - bounds origin)) ifFalse: [ ^last ].
+ last := pt.
+ ].
+ ^intersections first rounded!
Item was added:
+ ----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') -----
+ flipHorizontal
+
+ self form: (self form flipBy: #horizontal centerAt: self form center)!
Item was added:
+ ----- Method: SketchMorph>>flipVertical (in category 'e-toy support') -----
+ flipVertical
+
+ self form: (self form flipBy: #vertical centerAt: self form center)!
Item was added:
+ ----- Method: SketchMorph>>form (in category 'accessing') -----
+ form
+
+ ^ originalForm
+ !
Item was added:
+ ----- Method: SketchMorph>>form: (in category 'accessing') -----
+ form: aForm
+ "Set the receiver's form"
+
+ | oldForm topRenderer |
+ oldForm := originalForm.
+ (self hasProperty: #baseGraphic) ifFalse: [self setProperty: #baseGraphic toValue: aForm].
+ originalForm := aForm.
+ self rotationCenter: 0.5 at 0.5.
+ self layoutChanged.
+ topRenderer := self topRendererOrSelf.
+
+ oldForm ifNotNil: [topRenderer position: topRenderer position + (oldForm extent - aForm extent // 2)].
+ !
Item was added:
+ ----- Method: SketchMorph>>forwardDirection: (in category 'geometry eToy') -----
+ forwardDirection: degrees
+ "If not rotating normally, update my rotatedForm"
+ super forwardDirection: degrees.
+ rotationStyle == #normal ifFalse:[self layoutChanged].!
Item was added:
+ ----- Method: SketchMorph>>framesToDwell (in category 'accessing') -----
+ framesToDwell
+
+ ^ framesToDwell
+ !
Item was added:
+ ----- Method: SketchMorph>>framesToDwell: (in category 'accessing') -----
+ framesToDwell: anInteger
+
+ framesToDwell := anInteger.
+ !
Item was added:
+ ----- Method: SketchMorph>>generateInterpolatedForm (in category 'drawing') -----
+ generateInterpolatedForm
+ "Draw the given form onto the canvas using the Balloon 3D engine"
+ | aCanvas extent |
+ extent := (originalForm extent * scalePoint) asIntegerPoint.
+ rotatedForm := Form extent: extent asIntegerPoint depth: originalForm depth.
+ aCanvas := rotatedForm getCanvas.
+ ^self drawInterpolatedImage: originalForm on: aCanvas!
Item was added:
+ ----- Method: SketchMorph>>generateRotatedForm (in category 'drawing') -----
+ generateRotatedForm
+ "Compute my rotatedForm and offsetWhenRotated."
+
+ | scalePt smoothPix pair |
+ scalePoint ifNil: [scalePoint := 1 @ 1].
+ scalePt := scalePoint x abs @ scalePoint y abs.
+ rotationStyle == #none ifTrue: [scalePt := 1 @ 1].
+ smoothPix := (scalePt x < 1.0 or: [scalePt y < 1.0])
+ ifTrue: [2]
+ ifFalse: [1].
+ rotationStyle = #leftRight
+ ifTrue:
+ [self heading asSmallAngleDegrees < 0.0
+ ifTrue: [scalePt := scalePt x negated @ scalePt y]].
+ rotationStyle = #upDown
+ ifTrue:
+ [self heading asSmallAngleDegrees abs > 90.0
+ ifTrue: [scalePt := scalePt x @ scalePt y negated]].
+ rotatedForm := scalePt = (1 @ 1)
+ ifTrue: [originalForm]
+ ifFalse:
+ ["ar 11/19/2001: I am uncertain what happens in the case of rotationStyle ~~ normal"
+
+ (rotationStyle == #normal and: [self useInterpolation])
+ ifTrue: [^self generateInterpolatedForm].
+ pair := WarpBlt
+ rotate: originalForm
+ degrees: 0
+ center: originalForm boundingBox center
+ scaleBy: scalePt
+ smoothing: smoothPix.
+ pair first]!
Item was added:
+ ----- Method: SketchMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ ^ self initializeWith: (ScriptingSystem formAtKey: 'Painting') deepCopy!
Item was added:
+ ----- Method: SketchMorph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ super initializeToStandAlone.
+ self initializeWith: (ScriptingSystem formAtKey: 'Painting') deepCopy
+
+ !
Item was added:
+ ----- Method: SketchMorph>>initializeWith: (in category 'initialization') -----
+ initializeWith: aForm
+
+ super initialize.
+ originalForm := aForm.
+ self rotationCenter: 0.5 at 0.5. "relative to the top-left corner of the Form"
+ rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none"
+ scalePoint := 1.0 at 1.0.
+ framesToDwell := 1.
+ rotatedForm := originalForm. "cached rotation of originalForm"
+ self extent: originalForm extent.
+ !
Item was added:
+ ----- Method: SketchMorph>>insertIntoMovie: (in category 'menu') -----
+ insertIntoMovie: evt
+
+ | movies aTarget |
+ movies :=
+ (self world rootMorphsAt: evt hand targetPoint)
+ select: [:m | ((m isKindOf: MovieMorph) or:
+ [m isSketchMorph]) and: [m ~= self]].
+ movies isEmpty ifTrue: [^ self].
+ aTarget := movies first.
+ (aTarget isSketchMorph) ifTrue: [
+ aTarget := aTarget replaceSelfWithMovie].
+ aTarget insertFrames: (Array with: self).
+ self delete.
+ !
Item was added:
+ ----- Method: SketchMorph>>isLikelyRecipientForMouseOverHalos (in category 'halos and balloon help') -----
+ isLikelyRecipientForMouseOverHalos
+ ^ true!
Item was added:
+ ----- Method: SketchMorph>>keepAspectRatio (in category 'accessing') -----
+ keepAspectRatio
+
+ ^ keepAspectRatio ifNil: [false]!
Item was added:
+ ----- Method: SketchMorph>>keepAspectRatio: (in category 'accessing') -----
+ keepAspectRatio: aBoolean
+
+ keepAspectRatio := aBoolean.!
Item was added:
+ ----- Method: SketchMorph>>layoutChanged (in category 'layout') -----
+ layoutChanged
+ "Update rotatedForm and compute new bounds."
+ self changed.
+ self generateRotatedForm.
+ bounds := bounds origin extent: rotatedForm extent.
+ super layoutChanged.
+ self changed.
+ !
Item was added:
+ ----- Method: SketchMorph>>newForm: (in category 'other') -----
+ newForm: aForm
+ self originalForm: aForm.
+ self layoutChanged!
Item was added:
+ ----- Method: SketchMorph>>nominalForm: (in category 'accessing') -----
+ nominalForm: aForm
+ "Ascribe the blank nominal form"
+
+ originalForm := aForm.
+ self rotationCenter: 0.5 at 0.5.
+ self layoutChanged
+ !
Item was added:
+ ----- Method: SketchMorph>>originalForm: (in category 'accessing') -----
+ originalForm: aForm
+ originalForm := aForm!
Item was added:
+ ----- Method: SketchMorph>>penOnMyForm (in category 'pen support') -----
+ penOnMyForm
+ "Support for experiments with drawing under program control. To get started, make a new SketchMorph in a morphic world. In an inspector, give it the desired pixel dimensions with clearExtent:fillColor:. Then use this method to get a pen to which you can send normal pen commands. Reveal the resulting drawing with revealPenStrokes."
+
+ ^ Pen newOnForm: originalForm
+ !
Item was added:
+ ----- Method: SketchMorph>>recolorPixelsOfColor:with: (in category 'menu') -----
+ recolorPixelsOfColor: originalColor with: newColor
+ "Let the user select a color to be remapped, and then a color to map that color to, then carry it out."
+ | d newForm map |
+ d := originalForm depth.
+ newForm := Form extent: originalForm extent depth: d.
+ map := (Color cachedColormapFrom: d to: d) copy.
+ map at: (originalColor indexInMap: map) put: (newColor pixelValueForDepth: d).
+ newForm copyBits: newForm boundingBox
+ from: originalForm at: 0 at 0
+ colorMap: map.
+ self form: newForm.
+ !
Item was added:
+ ----- Method: SketchMorph>>recolorPixelsUsing: (in category 'menu') -----
+ recolorPixelsUsing: evt
+ "Let the user select a color to be remapped, and then a color to map that color to, then carry it out."
+ | originalColor newColor |
+ self inform: 'choose the color you want to replace' translated.
+ self
+ changeColorTarget: self
+ selector: #rememberedColor:
+ originalColor: nil
+ hand: evt hand.
+ "color to replace"
+ originalColor := self rememberedColor ifNil: [ ^ self ].
+ self inform: 'now choose the color you want to replace it with' translated.
+ self
+ changeColorTarget: self
+ selector: #rememberedColor:
+ originalColor: originalColor
+ hand: evt hand.
+ "new color"
+ newColor := self rememberedColor ifNil: [ ^ self ].
+ self
+ recolorPixelsOfColor: originalColor
+ with: newColor!
Item was added:
+ ----- Method: SketchMorph>>reduceColorPalette: (in category 'menu') -----
+ reduceColorPalette: evt
+ "Let the user ask for a reduced number of colors in this sketch"
+
+ | str nColors |
+ str := UIManager default
+ request: 'Please enter a number greater than one.
+ (note: this cannot be undone, so answer zero
+ to abort if you need to make a backup first)' translated
+ initialAnswer: '256'.
+ nColors := Integer readFrom: (ReadStream on: str).
+ (nColors between: 2 and: 256) ifFalse: [^ self].
+
+ originalForm := originalForm copyWithColorsReducedTo: nColors.
+ rotatedForm := nil.
+ self changed!
Item was added:
+ ----- Method: SketchMorph>>releaseCachedState (in category 'caching') -----
+ releaseCachedState
+ "Clear cache of rotated, scaled Form."
+
+ super releaseCachedState.
+ rotatedForm := nil.
+ originalForm hibernate!
Item was added:
+ ----- Method: SketchMorph>>replaceSelfWithMovie (in category 'other') -----
+ replaceSelfWithMovie
+ "Replace this SketchMorph in its owner with a MovieMorph containing this sketch as its only frame. This allows a SketchMorph to be turned into a MovieMorph by just insering additional frames."
+
+ | o movie |
+ self changed.
+ o := self owner.
+ movie := MovieMorph new position: self referencePosition.
+ movie insertFrames: (Array with: self).
+ o ifNil: [^ movie].
+ o addMorphFront: movie.
+ ^ movie
+ !
Item was added:
+ ----- Method: SketchMorph>>restoreBaseGraphic (in category 'menu') -----
+ restoreBaseGraphic
+ "Restore the receiver's base graphic"
+
+ | aGraphic |
+ ((aGraphic := self baseGraphic) notNil and:
+ [aGraphic ~= originalForm])
+ ifTrue:
+ [self form: aGraphic]!
Item was added:
+ ----- Method: SketchMorph>>restoreBaseGraphicFromMenu (in category 'menu') -----
+ restoreBaseGraphicFromMenu
+ "Restore the base graphic -- invoked from a menu, so give interactive feedback if appropriate"
+
+ self isInWorld ifFalse: [^ self inform:
+
+ 'oops, this menu is a for a morph that
+ has been replaced, probably because a
+ "look like" script was run. Please dismiss
+ the menu and get a new one!!. Sorry!!' translated].
+
+ self baseGraphic = originalForm ifTrue: [^ self inform: 'This object is *already* showing its baseGraphic' translated].
+ self restoreBaseGraphic!
Item was added:
+ ----- Method: SketchMorph>>revealPenStrokes (in category 'pen support') -----
+ revealPenStrokes
+ "This message must be sent after a sequence of pen strokes to make the resulting changes visible."
+
+ rotatedForm := nil.
+ self changed.
+ !
Item was added:
+ ----- Method: SketchMorph>>rotatedForm (in category 'accessing') -----
+ rotatedForm
+
+ rotatedForm ifNil: [self layoutChanged].
+ ^ rotatedForm
+ !
Item was added:
+ ----- Method: SketchMorph>>rotationStyle (in category 'e-toy support') -----
+ rotationStyle
+
+ ^ rotationStyle
+ !
Item was added:
+ ----- Method: SketchMorph>>rotationStyle: (in category 'e-toy support') -----
+ rotationStyle: aSymbol
+ "Set my rotation style to #normal, #leftRight, #upDown, or #none. Styles mean:
+ #normal -- continuous 360 degree rotation
+ #leftRight -- quantize angle to left or right facing
+ #upDown -- quantize angle to up or down facing
+ #none -- do not rotate"
+
+ rotationStyle := aSymbol.
+ self layoutChanged.
+ !
Item was added:
+ ----- Method: SketchMorph>>scaleFactor (in category 'accessing') -----
+ scaleFactor
+ "Answer the number representing my scaleFactor, assuming the receiver to be unflexed (if flexed, the renderer's scaleFactor is called instead"
+
+ | qty |
+ ((qty := self scalePoint) isPoint) ifTrue: [^1.0].
+ ^qty!
Item was added:
+ ----- Method: SketchMorph>>scalePoint (in category 'accessing') -----
+ scalePoint
+
+ scalePoint ifNil: [scalePoint := 1.0 at 1.0].
+ ^ scalePoint
+ !
Item was added:
+ ----- Method: SketchMorph>>scalePoint: (in category 'accessing') -----
+ scalePoint: aPoint
+
+ scalePoint := self keepAspectRatio
+ ifTrue: [aPoint max: aPoint transposed]
+ ifFalse: [aPoint].
+ self layoutChanged.!
Item was added:
+ ----- Method: SketchMorph>>setNewFormFrom: (in category 'accessing') -----
+ setNewFormFrom: formOrNil
+ "Set the receiver's form as indicated. If nil is provided, then a default form will be used, possibly retrieved from the receiver's defaultValue property"
+
+ | defaultImage |
+ formOrNil ifNotNil: [^ self form: formOrNil].
+ defaultImage := self defaultValueOrNil ifNil: [ScriptingSystem squeakyMouseForm].
+ self form: defaultImage
+ !
Item was added:
+ ----- Method: SketchMorph>>setRotationStyle (in category 'menu') -----
+ setRotationStyle
+ | selections labels sel reply |
+ selections := #(normal leftRight upDown none).
+ labels := #('rotate smoothly' 'left-right flip only' 'top-down flip only' 'don''t rotate').
+ sel := labels at: (selections indexOf: self rotationStyle ifAbsent:[1]).
+ labels := labels collect:[:lbl| sel = lbl ifTrue:['<on>', lbl translated] ifFalse:['<off>', lbl translated]].
+ reply := UIManager default chooseFrom: labels values: selections.
+ reply ifNotNil: [self rotationStyle: reply].
+ !
Item was added:
+ ----- Method: SketchMorph>>toggleInterpolation (in category 'menu') -----
+ toggleInterpolation
+ ^self useInterpolation: self useInterpolation not!
Item was added:
+ ----- Method: SketchMorph>>useInterpolation (in category 'accessing') -----
+ useInterpolation
+ ^(self valueOfProperty: #useInterpolation ifAbsent:[false])
+ and:[Smalltalk includesKey: #B3DRenderEngine]!
Item was added:
+ ----- Method: SketchMorph>>useInterpolation: (in category 'accessing') -----
+ useInterpolation: aBool
+ (aBool == true and: [ Smalltalk includesKey: #B3DRenderEngine ])
+ ifTrue:[self setProperty: #useInterpolation toValue: aBool]
+ ifFalse:[self removeProperty: #useInterpolation].
+ self layoutChanged. "to regenerate the form"
+ !
Item was added:
+ ----- Method: SketchMorph>>useInterpolationString (in category 'menu') -----
+ useInterpolationString
+ ^ (self useInterpolation
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ , 'smooth image' translated!
Item was added:
+ ----- Method: SketchMorph>>wantsDirectionHandles (in category 'halos and balloon help') -----
+ wantsDirectionHandles
+ ^self valueOfProperty: #wantsDirectionHandles ifAbsent:[
+ Preferences showDirectionHandles or:[Preferences showDirectionForSketches]]!
Item was added:
+ ----- Method: SketchMorph>>wantsDirectionHandles: (in category 'halos and balloon help') -----
+ wantsDirectionHandles: aBool
+ aBool == (Preferences showDirectionHandles or:[Preferences showDirectionForSketches])
+ ifTrue:[self removeProperty: #wantsDirectionHandles]
+ ifFalse:[self setProperty: #wantsDirectionHandles toValue: aBool].!
Item was added:
+ ----- Method: SketchMorph>>wantsRecolorHandle (in category 'e-toy support') -----
+ wantsRecolorHandle
+ "Answer whether the receiver would like a recolor handle to be
+ put up for it. We'd want to disable this but for the moment
+ that would cut off access to the button part of the properties
+ sheet. So this remains a loose end."
+ ^ false!
Item was added:
+ ----- Method: SketchMorph>>wantsSimpleSketchMorphHandles (in category 'accessing') -----
+ wantsSimpleSketchMorphHandles
+ "Answer true if my halo's simple handles should include the simple sketch morph handles."
+ ^self isMemberOf: SketchMorph!
Item was added:
+ MorphicModel subclass: #Slider
+ instanceVariableNames: 'slider value setValueSelector getValueSelector sliderShadow sliderColor descending minimumValue maximumValue quantum getMinimumValueSelector getMaximumValueSelector'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: Slider class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ "OK to instantiate"
+ ^ true!
Item was added:
+ ----- Method: Slider class>>on:getValue:setValue: (in category 'instance creation') -----
+ on: anObject getValue: getSel setValue: setSel
+ "Answer a new instance of the receiver with
+ the given selectors as the interface."
+
+ ^self new
+ on: anObject
+ getValue: getSel
+ setValue: setSel!
Item was added:
+ ----- Method: Slider class>>on:getValue:setValue:min:max:quantum: (in category 'instance creation') -----
+ on: anObject getValue: getSel setValue: setSel min: min max: max quantum: quantum
+ "Answer a new instance of the receiver with
+ the given selectors as the interface."
+
+ | instance |
+ instance := self new
+ quantum: quantum;
+ on: anObject
+ getValue: getSel
+ setValue: setSel.
+ min isSymbol
+ ifTrue: [instance getMinimumValueSelector: min]
+ ifFalse: [instance minimumValue: min].
+ max isSymbol
+ ifTrue: [instance getMaximumValueSelector: max]
+ ifFalse: [instance maximumValue: max].
+ ^ instance!
Item was added:
+ ----- Method: Slider>>adoptPaneColor: (in category 'accessing - ui') -----
+ adoptPaneColor: paneColor
+
+ super adoptPaneColor: paneColor.
+
+ paneColor ifNotNil: [:c |
+ self color: c.
+ self thumb color: c].!
Item was added:
+ ----- Method: Slider>>computeSlider (in category 'geometry') -----
+ computeSlider
+ | r v |
+ r := self roomToMove.
+ v := self maximumValue = self minimumValue
+ ifTrue: [0]
+ ifFalse: [(value - self minimumValue) / (self maximumValue - self minimumValue)].
+ self descending
+ ifFalse:
+ [slider position: (bounds isWide
+ ifTrue: [r topLeft + ((r width * v) asInteger @ 0)]
+ ifFalse: [r topLeft + (0 @ (r height * v) asInteger)])]
+ ifTrue:
+ [slider position: (bounds isWide
+ ifTrue: [r bottomRight - ((r width * v) asInteger @ 0)]
+ ifFalse: [r bottomRight - ((0 @ (r height * v) asInteger))])].
+ slider extent: self sliderExtent!
Item was added:
+ ----- Method: Slider>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ #inset!
Item was added:
+ ----- Method: Slider>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 1!
Item was added:
+ ----- Method: Slider>>defaultBounds (in category 'initialization') -----
+ defaultBounds
+ "answer the default bounds for the receiver"
+ ^ 0 @ 0 corner: 16 @ 100!
Item was added:
+ ----- Method: Slider>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color lightGray!
Item was added:
+ ----- Method: Slider>>descending (in category 'accessing') -----
+ descending
+
+ ^ descending!
Item was added:
+ ----- Method: Slider>>descending: (in category 'accessing') -----
+ descending: aBoolean
+
+ descending := aBoolean.
+ self computeSlider.!
Item was added:
+ ----- Method: Slider>>extent: (in category 'geometry') -----
+ extent: newExtent
+
+ (bounds extent closeTo: newExtent) ifTrue: [^ self].
+
+ bounds isWide
+ ifTrue: [super extent: (newExtent x max: self sliderThickness * 2) @ newExtent y]
+ ifFalse: [super extent: newExtent x @ (newExtent y max: self sliderThickness * 2)].
+
+ self updateSlider.!
Item was added:
+ ----- Method: Slider>>getMaximumValue (in category 'model access') -----
+ getMaximumValue
+
+ self getMaximumValueSelector ifNotNil: [:selector |
+ self maximumValue: (model perform: selector)].
+ ^ self maximumValue!
Item was added:
+ ----- Method: Slider>>getMaximumValueSelector (in category 'accessing - model') -----
+ getMaximumValueSelector
+
+ ^ getMaximumValueSelector!
Item was added:
+ ----- Method: Slider>>getMaximumValueSelector: (in category 'accessing - model') -----
+ getMaximumValueSelector: aSymbol
+
+ getMaximumValueSelector := aSymbol.!
Item was added:
+ ----- Method: Slider>>getMinimumValue (in category 'model access') -----
+ getMinimumValue
+
+ self getMinimumValueSelector ifNotNil: [:selector |
+ self minimumValue: (model perform: selector)].
+ ^ self minimumValue!
Item was added:
+ ----- Method: Slider>>getMinimumValueSelector (in category 'accessing - model') -----
+ getMinimumValueSelector
+
+ ^ getMinimumValueSelector!
Item was added:
+ ----- Method: Slider>>getMinimumValueSelector: (in category 'accessing - model') -----
+ getMinimumValueSelector: aSymbol
+
+ getMinimumValueSelector := aSymbol.!
Item was added:
+ ----- Method: Slider>>getValue (in category 'model access') -----
+ getValue
+ "Updates internal value with model data if possible. Returns the updated value or the current one."
+
+ self getValueSelector ifNotNil: [:selector |
+ self value: (model perform: selector)].
+ ^ self value!
Item was added:
+ ----- Method: Slider>>getValueSelector (in category 'accessing - model') -----
+ getValueSelector
+
+ ^ getValueSelector!
Item was added:
+ ----- Method: Slider>>getValueSelector: (in category 'accessing - model') -----
+ getValueSelector: aSymbol
+
+ getValueSelector := aSymbol.!
Item was added:
+ ----- Method: Slider>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ value := 0.0.
+ descending := false.
+ self initializeSlider!
Item was added:
+ ----- Method: Slider>>initializeSlider (in category 'initialization') -----
+ initializeSlider
+ slider := RectangleMorph newBounds: self totalSliderArea color: self thumbColor.
+ sliderShadow := RectangleMorph newBounds: self totalSliderArea
+ color: self pagingArea color.
+ slider on: #mouseMove send: #scrollAbsolute: to: self.
+ slider on: #mouseDown send: #mouseDownInSlider: to: self.
+ slider on: #mouseUp send: #mouseUpInSlider: to: self.
+ slider setBorderWidth: 1 borderColor: Color lightGray..
+ sliderShadow setBorderWidth: 1 borderColor: #inset.
+ "(the shadow must have the pagingArea as its owner to highlight properly)"
+ self pagingArea addMorph: sliderShadow.
+ sliderShadow hide.
+ self addMorph: slider.
+ self computeSlider.
+ !
Item was added:
+ ----- Method: Slider>>maximumValue (in category 'accessing') -----
+ maximumValue
+
+ ^ maximumValue ifNil: [1.0]!
Item was added:
+ ----- Method: Slider>>maximumValue: (in category 'accessing') -----
+ maximumValue: aNumber
+
+ maximumValue := aNumber.
+ self setValue: self value.!
Item was added:
+ ----- Method: Slider>>minimumValue (in category 'accessing') -----
+ minimumValue
+ ^ minimumValue ifNil: [0.0]!
Item was added:
+ ----- Method: Slider>>minimumValue: (in category 'accessing') -----
+ minimumValue: aNumber
+
+ minimumValue := aNumber.
+ self setValue: self value.!
Item was added:
+ ----- Method: Slider>>mouseDownInSlider: (in category 'other events') -----
+ mouseDownInSlider: event
+
+ slider borderStyle style == #raised
+ ifTrue: [slider borderColor: #inset].
+
+ sliderShadow color: self sliderShadowColor.
+ sliderShadow cornerStyle: slider cornerStyle.
+ sliderShadow bounds: slider bounds.
+ sliderShadow show!
Item was added:
+ ----- Method: Slider>>mouseUpInSlider: (in category 'other events') -----
+ mouseUpInSlider: event
+
+ slider borderStyle style == #inset
+ ifTrue: [slider borderColor: #raised].
+
+ sliderShadow hide!
Item was added:
+ ----- Method: Slider>>on:getValue:setValue: (in category 'initialization') -----
+ on: anObject getValue: getSel setValue: setSel
+
+ self
+ model: anObject;
+ getValueSelector: getSel;
+ setValueSelector: setSel;
+ getValue.!
Item was added:
+ ----- Method: Slider>>pagingArea (in category 'accessing - ui') -----
+ pagingArea
+ ^self!
Item was added:
+ ----- Method: Slider>>quantum (in category 'accessing') -----
+ quantum
+
+ ^ quantum!
Item was added:
+ ----- Method: Slider>>quantum: (in category 'accessing') -----
+ quantum: aNumber
+
+ quantum := aNumber.
+ self setValue: self value.!
Item was added:
+ ----- Method: Slider>>roomToMove (in category 'geometry') -----
+ roomToMove
+ ^ self totalSliderArea insetBy: (0 at 0 extent: self sliderExtent)!
Item was added:
+ ----- Method: Slider>>scrollAbsolute: (in category 'scrolling') -----
+ scrollAbsolute: event
+ | r p |
+ r := self roomToMove.
+ bounds isWide
+ ifTrue: [r width = 0 ifTrue: [^ self]]
+ ifFalse: [r height = 0 ifTrue: [^ self]].
+ p := event targetPoint adhereTo: r.
+ self descending
+ ifFalse:
+ [self setValueFraction: (bounds isWide
+ ifTrue: [(p x - r left) asFloat / r width]
+ ifFalse: [(p y - r top) asFloat / r height])]
+ ifTrue:
+ [self setValueFraction: (bounds isWide
+ ifTrue: [(r right - p x) asFloat / r width]
+ ifFalse: [(r bottom - p y) asFloat / r height])]!
Item was added:
+ ----- Method: Slider>>scrollBy: (in category 'scrolling') -----
+ scrollBy: delta
+
+ self setValue: self value + delta.!
Item was added:
+ ----- Method: Slider>>setValue: (in category 'model access') -----
+ setValue: newValue
+ "Either changes the value directly or tries to go the loop through the model. See #update:."
+
+ self setValueSelector ifNotNil: [:selector |
+ | trimmedValue |
+ trimmedValue := self trimmedValue: newValue.
+ "Only notify about changed values."
+ trimmedValue ~= self value ifTrue: [
+ model perform: selector with: trimmedValue]].
+
+ (self setValueSelector isNil or: [self getValueSelector isNil])
+ ifTrue: [self value: newValue].!
Item was added:
+ ----- Method: Slider>>setValueFraction: (in category 'support') -----
+ setValueFraction: newValueFraction
+
+ self setValue: (newValueFraction * (self maximumValue - self minimumValue)) + self minimumValue.!
Item was added:
+ ----- Method: Slider>>setValueSelector (in category 'accessing - model') -----
+ setValueSelector
+
+ ^ setValueSelector!
Item was added:
+ ----- Method: Slider>>setValueSelector: (in category 'accessing - model') -----
+ setValueSelector: aSymbol
+
+ setValueSelector := aSymbol.!
Item was added:
+ ----- Method: Slider>>sliderColor (in category 'accessing - ui') -----
+ sliderColor
+ "color scheme for the whole slider widget"
+ sliderColor ifNil: [^ (color alphaMixed: 0.7 with: Color white) slightlyLighter].
+ ^ sliderColor!
Item was added:
+ ----- Method: Slider>>sliderColor: (in category 'accessing - ui') -----
+ sliderColor: newColor
+
+ sliderColor := newColor.
+ slider ifNotNil: [slider color: sliderColor]!
Item was added:
+ ----- Method: Slider>>sliderExtent (in category 'geometry') -----
+ sliderExtent
+ ^ bounds isWide
+ ifTrue: [self sliderThickness @ self innerBounds height]
+ ifFalse: [self innerBounds width @ self sliderThickness]!
Item was added:
+ ----- Method: Slider>>sliderShadowColor (in category 'accessing - ui') -----
+ sliderShadowColor
+ ^ self sliderColor alphaMixed: 0.2 with: self pagingArea color!
Item was added:
+ ----- Method: Slider>>sliderThickness (in category 'geometry') -----
+ sliderThickness
+ ^ 7!
Item was added:
+ ----- Method: Slider>>thumb (in category 'accessing - ui') -----
+ thumb
+
+ ^ slider!
Item was added:
+ ----- Method: Slider>>thumbColor (in category 'accessing - ui') -----
+ thumbColor
+ "Color of the draggable 'thumb'"
+ ^ self sliderColor!
Item was added:
+ ----- Method: Slider>>totalSliderArea (in category 'geometry') -----
+ totalSliderArea
+ ^ self innerBounds!
Item was added:
+ ----- Method: Slider>>trimValue: (in category 'support') -----
+ trimValue: aValue
+
+ | trimmedValue |
+ trimmedValue := aValue min: self maximumValue max: self minimumValue.
+ self quantum ifNotNil: [:q | trimmedValue := trimmedValue roundTo: q].
+ ^ trimmedValue
+ !
Item was added:
+ ----- Method: Slider>>trimmedValue: (in category 'support') -----
+ trimmedValue: aValue
+
+ | trimmedValue |
+ trimmedValue := aValue min: self maximumValue max: self minimumValue.
+ self quantum ifNotNil: [:q | trimmedValue := trimmedValue roundTo: q].
+ ^ trimmedValue
+ !
Item was added:
+ ----- Method: Slider>>truncate (in category 'accessing') -----
+ truncate
+
+ ^ self quantum == 1!
Item was added:
+ ----- Method: Slider>>truncate: (in category 'accessing') -----
+ truncate: aBoolean
+
+ self quantum: (aBoolean ifTrue: [1] ifFalse: [nil]).!
Item was added:
+ ----- Method: Slider>>update: (in category 'updating') -----
+ update: aSymbol
+ "Update the value."
+
+ super update: aSymbol.
+
+ aSymbol = self getValueSelector ifTrue: [self getValue. ^ self].
+ aSymbol = self getMinimumValueSelector ifTrue: [self getMinimumValue. ^ self].
+ aSymbol = self getMaximumValueSelector ifTrue: [self getMaximumValue. ^ self].!
Item was added:
+ ----- Method: Slider>>updateSlider (in category 'initialization') -----
+ updateSlider
+ "Updates layout properties of the slider."
+
+ slider bounds: self totalSliderArea.
+ sliderShadow bounds: slider bounds.
+
+ self computeSlider.
+ !
Item was added:
+ ----- Method: Slider>>value (in category 'accessing') -----
+ value
+
+ ^ value!
Item was added:
+ ----- Method: Slider>>value: (in category 'accessing') -----
+ value: newValue
+
+ | t |
+ t := self trimmedValue: newValue.
+ t = value ifTrue: [^ self].
+
+ value := t.
+ self computeSlider.!
Item was added:
+ ----- Method: Slider>>wantsSlot (in category 'testing') -----
+ wantsSlot
+ "For now do it the old way, until we sort this out"
+ ^ true!
Item was added:
+ TextEditor subclass: #SmalltalkEditor
+ instanceVariableNames: 'styler'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !SmalltalkEditor commentStamp: 'jmv 8/8/2009 15:10' prior: 0!
+ The editor built specifically for Smalltalk code!
Item was added:
+ ----- Method: SmalltalkEditor class>>initialize (in category 'keyboard shortcut tables') -----
+ initialize
+ "SmalltalkEditor initialize"
+ self initializeCmdKeyShortcuts.
+ self initializeShiftCmdKeyShortcuts.
+ self initializeYellowButtonMenu.
+ self initializeShiftedYellowButtonMenu.
+ !
Item was added:
+ ----- Method: SmalltalkEditor class>>initializeCmdKeyShortcuts (in category 'keyboard shortcut tables') -----
+ initializeCmdKeyShortcuts
+ "Initialize the (unshifted) command-key (or alt-key) shortcut table."
+ "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
+ "SmalltalkEditor initialize"
+ | cmds |
+ super initializeCmdKeyShortcuts.
+ cmds := #($b #browseIt: $d #doIt: $i #inspectIt: $j #doAgainOnce: $l #cancel: $m #implementorsOfIt: $n #sendersOfIt: $o #spawnIt: $p #printIt: $q #querySymbol: $s #save: ).
+ 1 to: cmds size
+ by: 2
+ do: [ : i | cmdActions at: (cmds at: i) asciiValue + 1 put: (cmds at: i + 1)].
+ "Set up type-method argument hot keys, 1-4.."
+ '1234' do:
+ [ : eachKeyboardChar |
+ cmdActions
+ at: eachKeyboardChar asciiValue + 1
+ put: #typeMethodArgument: ]!
Item was added:
+ ----- Method: SmalltalkEditor class>>initializeShiftCmdKeyShortcuts (in category 'keyboard shortcut tables') -----
+ initializeShiftCmdKeyShortcuts
+ "Initialize the shift-command-key (or control-key) shortcut table."
+ "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
+ "wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the
+ capitalized versions of the letters.
+ TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values."
+
+ "SmalltalkEditor initialize"
+
+ | cmds |
+ super initializeShiftCmdKeyShortcuts.
+
+ cmds := #(
+ $a argAdvance:
+ $b browseItHere:
+ $e methodStringsContainingIt:
+ $f displayIfFalse:
+ $g fileItIn:
+ $i exploreIt:
+ $n referencesToIt:
+ $s invokePrettyPrint:
+ $t displayIfTrue:
+ $v pasteInitials:
+ $w methodNamesContainingIt:
+ ).
+ 1 to: cmds size by: 2 do: [ :i |
+ shiftCmdActions at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1). "plain keys"
+ shiftCmdActions at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1). "shifted keys"
+ shiftCmdActions at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1). "ctrl keys"
+ ].!
Item was added:
+ ----- Method: SmalltalkEditor class>>initializeShiftedYellowButtonMenu (in category 'keyboard shortcut tables') -----
+ initializeShiftedYellowButtonMenu
+ "Initialize the yellow button pop-up menu and corresponding messages."
+
+ "SmalltalkEditor initialize"
+
+ shiftedYellowButtonMenu := MenuMorph fromArray: StringHolder yellowButtonMenuItems.!
Item was added:
+ ----- Method: SmalltalkEditor class>>initializeYellowButtonMenu (in category 'keyboard shortcut tables') -----
+ initializeYellowButtonMenu
+ "Initialize the yellow button pop-up menu and corresponding messages."
+
+ "SmalltalkEditor initialize"
+
+ yellowButtonMenu := MenuMorph fromArray: StringHolder yellowButtonMenuItems!
Item was added:
+ ----- Method: SmalltalkEditor>>blinkPrevParen: (in category 'parenblinking') -----
+ blinkPrevParen: aCharacter
+ "Same as super, but tries to follow the Smalltalk syntax."
+
+ | openDelimiter closeDelimiter level string here inside |
+ string := paragraph text string.
+ here := pointBlock stringIndex.
+ openDelimiter := aCharacter.
+ closeDelimiter := '([{' at: (')]}' indexOf: openDelimiter).
+ level := 1.
+ inside := nil. "Tricky."
+ (here > 1 and: [ (string at: here - 1) = $$ ]) ifTrue: [ ^self ]. "Just a character literal."
+ [ level > 0 and: [ here > 1 ] ] whileTrue: [
+ | hereChar |
+ hereChar := string at: (here := here - 1).
+ inside "Are we inside a comment or string literal?"
+ ifNotNil: [ "Yes."
+ hereChar = inside ifTrue: [
+ (here > 1 and: [ (string at: here - 1) ~= inside ])
+ ifTrue: [ inside := nil ]
+ ifFalse: [ here := here - 1 ] ] ]
+ ifNil: [
+ (here > 1 and: [ (string at: here - 1) = $$ ]) "Just a character literal."
+ ifTrue: [ here := here - 1 ]
+ ifFalse: [
+ hereChar
+ caseOf: {
+ [ closeDelimiter ] -> [
+ (level := level - 1) = 0 ifTrue: [
+ ^self blinkParenAt: here ] ].
+ [ openDelimiter ] -> [ level := level + 1 ].
+ [ $" ] -> [ inside := $" ].
+ [ $' ] -> [ inside := $' ] }
+ otherwise: [] ] ] ]!
Item was added:
+ ----- Method: SmalltalkEditor>>buttonForIt (in category 'do-its') -----
+ buttonForIt
+
+ ^ self doItButtonFromSelection ifNotNilDo: [:e | e openInHand]!
Item was added:
+ ----- Method: SmalltalkEditor>>changeEmphasis: (in category 'editing keys') -----
+ changeEmphasis: characterStream
+ "Change emphasis without styling if necessary"
+ styler ifNil: [^super changeEmphasis: characterStream].
+ ^styler evaluateWithoutStyling: [super changeEmphasis: characterStream].!
Item was added:
+ ----- Method: SmalltalkEditor>>doItButtonFromSelection (in category 'do-its') -----
+ doItButtonFromSelection
+
+ | button string cm |
+ self lineSelectAndEmptyCheck: [^ nil].
+ button := SimpleButtonMorph new.
+ string := self selection.
+ (model respondsTo: #doItReceiver)
+ ifTrue: [
+ button setProperty: #rcvr toValue: model doItReceiver.
+ button setProperty: #ctxt toValue: model doItContext].
+
+ cm := (button valueOfProperty: #rcvr) class compilerClass new
+ compiledMethodFor: string readStream
+ in: (button valueOfProperty: #ctxt)
+ to: (button valueOfProperty: #rcvr)
+ notifying: nil
+ ifFail: [^ nil].
+ button setProperty: #cm toValue: cm.
+ button target: [:b |
+ [(b valueOfProperty: #cm) valueWithReceiver: (b valueOfProperty: #rcvr) arguments:
+ ((b valueOfProperty: #ctxt) ifNotNil: [{(b valueOfProperty: #ctxt) }] ifNil: [#()])]
+ on: OutOfScopeNotification
+ do: [ :ex | ex resume: true]];
+ actionSelector: #value:;
+ arguments: {button}.
+ button label: string.
+ ^ button.
+ !
Item was added:
+ ----- Method: SmalltalkEditor>>emphasisExtras (in category 'editing keys') -----
+ emphasisExtras
+ ^#(
+ 'Do it'
+ 'Print it'
+ 'Link to comment of class'
+ 'Link to definition of class'
+ 'Link to hierarchy of class'
+ 'Link to method'
+ 'URL Link'
+ ).!
Item was added:
+ ----- Method: SmalltalkEditor>>handleEmphasisExtra:with: (in category 'editing keys') -----
+ handleEmphasisExtra: index with: aKeyboardEvent
+ "Handle an extra emphasis menu item"
+ | action attribute thisSel |
+ action := {
+ [attribute := TextDoIt new.
+ thisSel := attribute analyze: self selection asString].
+ [attribute := TextPrintIt new.
+ thisSel := attribute analyze: self selection asString].
+ [attribute := TextLink new.
+ thisSel := attribute analyze: self selection asString with: 'Comment'].
+ [attribute := TextLink new.
+ thisSel := attribute analyze: self selection asString with: 'Definition'].
+ [attribute := TextLink new.
+ thisSel := attribute analyze: self selection asString with: 'Hierarchy'].
+ [attribute := TextLink new.
+ thisSel := attribute analyze: self selection asString].
+ [attribute := TextURL new.
+ thisSel := attribute analyze: self selection asString].
+ ["Edit hidden info"
+ thisSel := self hiddenInfo. "includes selection"
+ attribute := TextEmphasis normal].
+ ["Copy hidden info"
+ self copyHiddenInfo.
+ ^true]. "no other action"
+ } at: index.
+ action value.
+
+ thisSel ifNil: [^true]. "Could not figure out what to link to"
+
+ attribute ifNotNil: [
+ thisSel ifEmpty:[ | oldAttributes |
+ "only change emphasisHere while typing"
+ oldAttributes := paragraph text attributesAt: self pointIndex.
+ emphasisHere := Text addAttribute: attribute toArray: oldAttributes.
+ ] ifNotEmpty: [
+ self replaceSelectionWith: (thisSel asText addAttribute: attribute).
+ ]
+ ].
+ ^true!
Item was added:
+ ----- Method: SmalltalkEditor>>invokePrettyPrint: (in category 'editing keys') -----
+ invokePrettyPrint: dummy
+ self prettyPrint: false.
+ ^ true!
Item was added:
+ ----- Method: SmalltalkEditor>>methodArgument: (in category 'private') -----
+ methodArgument: anInteger
+ ^ (ReadStream on: self text asString) nextLine
+ ifNil: [ String empty ]
+ ifNotNilDo:
+ [ : line |
+ line substrings
+ at: 2 * anInteger
+ ifAbsent: [ String empty ] ]!
Item was added:
+ ----- Method: SmalltalkEditor>>select (in category 'compatibility') -----
+ select
+ "Sent by the parser when correcting variables etc. Ignored here."!
Item was added:
+ ----- Method: SmalltalkEditor>>spyOnIt (in category 'do-its') -----
+ spyOnIt
+
+ ^ MessageTally spyOn: [self evaluateSelection]!
Item was added:
+ ----- Method: SmalltalkEditor>>styler (in category 'accessing') -----
+ styler
+ "Answers the styler for this editor. Only code editors support syntax highlighting"
+ ^styler
+ !
Item was added:
+ ----- Method: SmalltalkEditor>>styler: (in category 'accessing') -----
+ styler: aStyler
+ "Sets the styler for this editor. Only code editors support syntax highlighting"
+ ^styler := aStyler!
Item was added:
+ ----- Method: SmalltalkEditor>>tallyIt (in category 'do-its') -----
+ tallyIt
+
+ ^ self tallySelection!
Item was added:
+ ----- Method: SmalltalkEditor>>tallySelection (in category 'do-its') -----
+ tallySelection
+ "Treat the current selection as an expression; evaluate it and return the time took for this evaluation"
+ | result rcvr ctxt valueAsString v |
+ self lineSelectAndEmptyCheck: [^ self].
+
+ (model respondsTo: #doItReceiver)
+ ifTrue: [ rcvr := model doItReceiver.
+ ctxt := model doItContext]
+ ifFalse: [rcvr := ctxt := nil].
+ result := [ | cm |
+ cm := rcvr class evaluatorClass new
+ compiledMethodFor: self selectionAsStream
+ in: ctxt
+ to: rcvr
+ notifying: self
+ ifFail: [morph flash. ^ self].
+ Time millisecondsToRun:
+ [v := cm valueWithReceiver: rcvr arguments: #() ].
+ ]
+ on: OutOfScopeNotification
+ do: [ :ex | ex resume: true].
+
+ "We do not want to have large result displayed"
+ valueAsString := v printString.
+ (valueAsString size > 30) ifTrue: [valueAsString := (valueAsString copyFrom: 1 to: 30), '...'].
+ PopUpMenu
+ inform: 'Time to compile and execute: ', result printString, 'ms res: ', valueAsString.
+ !
Item was added:
+ ----- Method: SmalltalkEditor>>typeMethodArgument: (in category 'private') -----
+ typeMethodArgument: aKeyboardEvent
+ "Replace the current text selection with the name of the method argument represented by the keyCode."
+ | keyCode |
+ keyCode := ('1234'
+ indexOf: aKeyboardEvent keyCharacter
+ ifAbsent: [1]).
+ self addString: (self methodArgument: keyCode).
+ ^ false!
Item was added:
+ ----- Method: SmartRefStream>>bookPageMorphbosfcepcbbfgcc0 (in category '*Morphic-conversion') -----
+ bookPageMorphbosfcepcbbfgcc0
+ "BookPageMorph->PasteUpMorph. For reading in old BookMorphs."
+
+ ^ PasteUpMorph
+ !
Item was added:
+ ----- Method: SmartRefStream>>clippingMorphbosfcep0 (in category '*Morphic-conversion') -----
+ clippingMorphbosfcep0
+ ^ PasteUpMorph!
Item was added:
+ ----- Method: SmartRefStream>>clippingMorphbosfcepc0 (in category '*Morphic-conversion') -----
+ clippingMorphbosfcepc0
+ "ClippingMorph->PasteUpMorph. For reading in old BookMorphs."
+
+ ^ PasteUpMorph!
Item was added:
+ ----- Method: SmartRefStream>>dropShadowMorphbosfces0 (in category '*Morphic-conversion') -----
+ dropShadowMorphbosfces0
+
+ ^ Morph !
Item was added:
+ ----- Method: SmartRefStream>>layoutMorphbosfcepbbochvimol0 (in category '*Morphic-conversion') -----
+ layoutMorphbosfcepbbochvimol0
+ ^ AlignmentMorph!
Item was added:
+ ----- Method: SmartRefStream>>layoutMorphbosfcepcbbochvimol0 (in category '*Morphic-conversion') -----
+ layoutMorphbosfcepcbbochvimol0
+ ^ AlignmentMorph!
Item was added:
+ ----- Method: SmartRefStream>>morphicEventtcbks0 (in category '*Morphic-conversion') -----
+ morphicEventtcbks0
+ ^ MorphicEvent!
Item was added:
+ ----- Method: SmartRefStream>>morphicSoundEventtcbkss0 (in category '*Morphic-conversion') -----
+ morphicSoundEventtcbkss0
+ ^ MorphicUnknownEvent!
Item was added:
+ ----- Method: SmartRefStream>>myMorphbosfce0 (in category '*Morphic-conversion') -----
+ myMorphbosfce0
+
+ reshaped at: #MyMorph put: #convertbosfce0:bosfce0:.
+ "Be sure to define that conversion method in class Morph"
+ ^ Morph!
Item was added:
+ ----- Method: SmartRefStream>>newMorphicEventts0 (in category '*Morphic-conversion') -----
+ newMorphicEventts0
+
+ ^ MorphicEvent!
Item was added:
+ ImageMorph subclass: #Sonogram
+ instanceVariableNames: 'lastX scrollDelta columnForm minVal maxVal pixValMap'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Sound-Synthesis'!
+
+ !Sonogram commentStamp: '<historical>' prior: 0!
+ Sonograms are imageMorphs that will repeatedly plot arrays of values as black on white columns moving to the right in time and scrolling left as necessary.!
Item was added:
+ ----- Method: Sonogram>>extent: (in category 'geometry') -----
+ extent: newExtent
+ super image: (Form extent: newExtent depth: Display depth).
+ lastX := -1.
+ columnForm := Form extent: (32//image depth)@(image height) depth: image depth.
+ pixValMap := ((1 to: 256) collect:
+ [:i | columnForm pixelValueFor: (Color gray: (256-i)/255.0)])
+ as: Bitmap.
+ !
Item was added:
+ ----- Method: Sonogram>>extent:minVal:maxVal:scrollDelta: (in category 'all') -----
+ extent: extent minVal: min maxVal: max scrollDelta: d
+ minVal := min.
+ maxVal := max.
+ scrollDelta := d.
+ self extent: extent.
+
+ " try following with scrolldelta = 1, 20, 200
+ | s data |
+ s := Sonogram new extent: 200 at 50
+ minVal: 0.0 maxVal: 1.0 scrollDelta: 20.
+ World addMorph: s.
+ data := (1 to: 133) collect: [:i | 0.0].
+ 1 to: 300 do:
+ [:i | data at: (i\\133)+1 put: 1.0.
+ s plotColumn: data.
+ data at: (i\\133)+1 put: 0.0.
+ World doOneCycleNow].
+ s delete
+ "!
Item was added:
+ ----- Method: Sonogram>>plotColumn: (in category 'all') -----
+ plotColumn: dataArray
+ | chm1 i normVal r |
+ columnForm unhibernate.
+ chm1 := columnForm height - 1.
+ 0 to: chm1
+ do:
+ [:y |
+ i := y * (dataArray size - 1) // chm1 + 1.
+ normVal := ((dataArray at: i) - minVal) / (maxVal - minVal).
+ normVal := normVal max: 0.0.
+ normVal := normVal min: 1.0.
+ columnForm bits at: chm1 - y + 1
+ put: (pixValMap at: (normVal * 255.0) truncated + 1)].
+ (lastX := lastX + 1) > (image width - 1) ifTrue: [self scroll].
+ image
+ copy: (r := lastX @ 0 extent: 1 @ image height)
+ from: (32 // image depth - 1) @ 0
+ in: columnForm
+ rule: Form over.
+ "self changed."
+ self invalidRect: (r translateBy: self position)!
Item was added:
+ ----- Method: Sonogram>>scroll (in category 'all') -----
+ scroll
+ image copy: (scrollDelta at 0 extent: (image width-scrollDelta)@image height)
+ from: image to: 0 at 0 rule: Form over.
+ lastX := lastX - scrollDelta.
+ self changed!
Item was added:
+ Object subclass: #StandardScriptingSystem
+ instanceVariableNames: ''
+ classVariableNames: 'ClassVarNamesInUse FormDictionary HelpStrings StandardPartsBin'
+ poolDictionaries: ''
+ category: 'Morphic-Worlds'!
+
+ !StandardScriptingSystem commentStamp: '<historical>' prior: 0!
+ An instance of this is installed as the value of the global variable "ScriptingSystem". Client subclasses are invited, such as one used internally by squeak team for ongoing internal work.!
Item was added:
+ ----- Method: StandardScriptingSystem class>>cleanUp: (in category 'class initialization') -----
+ cleanUp: agressive
+ "Clean up unreferenced players. If agressive, reinitialize and nuke players"
+
+ self removeUnreferencedPlayers.
+ agressive ifTrue:[
+ References keys do: [:k | References removeKey: k].
+ self initialize.
+ ].!
Item was added:
+ ----- Method: StandardScriptingSystem class>>initialize (in category 'class initialization') -----
+ initialize
+ "Initialize the scripting system. Sometimes this method is vacuously changed just to get it in a changeset so that its invocation will occur as part of an update"
+
+ (self environment at: #ScriptingSystem ifAbsent: [nil]) ifNil:
+ [self environment at: #ScriptingSystem put: self new].
+
+ ScriptingSystem
+ initializeHelpStrings.
+
+ self registerInFlapsRegistry.
+
+ "StandardScriptingSystem initialize"!
Item was added:
+ ----- Method: StandardScriptingSystem class>>removeUnreferencedPlayers (in category 'class initialization') -----
+ removeUnreferencedPlayers
+ "Remove existing but unreferenced player references"
+ "StandardScriptingSystem removeUnreferencedPlayers"
+ References keys do:
+ [ : key | | ref |
+ ref := References at: key.
+ ((ref respondsTo: #costume) and: [ ref costume pasteUpMorph isNil ]) ifTrue: [ References removeKey: key ] ]!
Item was added:
+ ----- Method: StandardScriptingSystem>>allClassVarNamesInSystem (in category 'utilities') -----
+ allClassVarNamesInSystem
+ "Compute and answer a set of all the class variable names known to the sytem from any class"
+
+ | aList |
+ aList := OrderedCollection new.
+ Object withAllSubclasses do:
+ [:c | aList addAll: c allClassVarNames].
+ ^ aList asSet
+
+ "ScriptingSystem allClassVarNamesInSystem"
+ !
Item was added:
+ ----- Method: StandardScriptingSystem>>customizeForEToyUsers: (in category 'utilities') -----
+ customizeForEToyUsers: aBoolean
+ "If aBoolean is true, set things up for etoy users. If it's false, unset some of those things. Some things are set when switching into etoy mode but not reversed when switching out of etoy mode."
+
+ #(
+ (allowEtoyUserCustomEvents no reverse)
+ (balloonHelpEnabled yes dontReverse)
+ (debugHaloHandle no reverse)
+ (modalColorPickers yes dontReverse)
+ (oliveHandleForScriptedObjects no dontReverse)
+ (uniqueNamesInHalos yes reverse)
+ (useUndo yes dontReverse)
+ (infiniteUndo no dontReverse)
+ (warnIfNoChangesFile no reverse)
+ (warnIfNoSourcesFile no reverse)) do:
+ [:trip |
+ (aBoolean or: [trip third == #reverse]) ifTrue:
+ [Preferences enableOrDisable: trip first asPer:
+ ((trip second == #yes) & aBoolean) | ((trip second == #no) & aBoolean not)]]!
Item was added:
+ ----- Method: StandardScriptingSystem>>deletePrivateGraphics (in category 'form dictionary') -----
+ deletePrivateGraphics
+ "ScriptingSystem deletePrivateGraphics"
+ self deletePrivateGraphics: self privateGraphics
+ afterStoringToFileNamed: 'disGraphics'!
Item was added:
+ ----- Method: StandardScriptingSystem>>deletePrivateGraphics:afterStoringToFileNamed: (in category 'form dictionary') -----
+ deletePrivateGraphics: nameList afterStoringToFileNamed: aFileName
+ "This method is used to strip private graphics from the FormDictionary and store them on a file of the given name"
+
+ | replacement toRemove aReferenceStream |
+ toRemove := Dictionary new.
+ replacement := FormDictionary at: #Gets.
+
+ nameList do:
+ [:aKey |
+ | keySymbol |
+ keySymbol := aKey asSymbol.
+ (toRemove at: keySymbol put: (self formAtKey: keySymbol)).
+ FormDictionary at: keySymbol put: replacement].
+
+ aReferenceStream := ReferenceStream fileNamed: aFileName.
+ aReferenceStream nextPut: toRemove.
+ aReferenceStream close!
Item was added:
+ ----- Method: StandardScriptingSystem>>formAtKey: (in category 'form dictionary') -----
+ formAtKey: aString
+ "Answer the form saved under the given key"
+
+ Symbol hasInterned: aString ifTrue:
+ [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
+ ^ nil!
Item was added:
+ ----- Method: StandardScriptingSystem>>formAtKey:extent:depth: (in category 'form dictionary') -----
+ formAtKey: aKey extent: extent depth: depth
+ "ScriptingSystem saveForm: (TileMorph downPicture) atKey: 'downArrow'"
+ ^ FormDictionary at: aKey asSymbol ifAbsent: [Form extent: extent depth: depth]!
Item was added:
+ ----- Method: StandardScriptingSystem>>formDictionary (in category 'form dictionary') -----
+ formDictionary
+ ^FormDictionary!
Item was added:
+ ----- Method: StandardScriptingSystem>>helpStringOrNilFor: (in category 'help dictionary') -----
+ helpStringOrNilFor: aSymbol
+ "If my HelpStrings dictionary has an entry at the given symbol,
+ answer that entry's value, else answer nil"
+ HelpStrings
+ at: aSymbol
+ ifPresent:[:string | ^ string translated].
+ ^ nil!
Item was added:
+ ----- Method: StandardScriptingSystem>>initializeHelpStrings (in category 'help dictionary') -----
+ initializeHelpStrings
+ "Initialize the data structure that determines, for the etoy system, help messages for various scripting elements. The structure is built up by letting every Morph subclass contribute elements simply by implementing method #helpContributions. Consult implementors of #helpContributions for examples of how this goes."
+
+ "ScriptingSystem initializeHelpStrings"
+
+ | aDictionary |
+ aDictionary := IdentityDictionary new.
+ "For safety, the new copy is built up in this temp first, so that if an error occurs during the creation of the structure, the old version will remain remain in place"
+
+ Morph withAllSubclasses do:
+ [:aClass | (aClass class includesSelector: #helpContributions)
+ ifTrue:
+ [aClass helpContributions do:
+ [:pair | aDictionary at: pair first put: pair second]]].
+
+ HelpStrings := aDictionary!
Item was added:
+ ----- Method: StandardScriptingSystem>>inspectFormDictionary (in category 'form dictionary') -----
+ inspectFormDictionary
+ "ScriptingSystem inspectFormDictionary"
+
+ GraphicalDictionaryMenu openOn: FormDictionary withLabel: 'Testing One Two Three'!
Item was added:
+ ----- Method: StandardScriptingSystem>>privateGraphics (in category 'form dictionary') -----
+ privateGraphics
+ "ScriptingSystem deletePrivateGraphics"
+ ^#(#BadgeMiniPic #BadgePic #Broom #CedarPic #CollagePic #CoverMain #CoverSpiral #CoverTexture #Fred #ImagiPic #KayaPic #StudioPic)!
Item was added:
+ ----- Method: StandardScriptingSystem>>saveForm:atKey: (in category 'form dictionary') -----
+ saveForm: aForm atKey: aKey
+ FormDictionary at: aKey asSymbol put: aForm!
Item was added:
+ ----- Method: StandardScriptingSystem>>soundNamesToSuppress (in category 'utilities') -----
+ soundNamesToSuppress
+ "Answer a list of sound-names that are not to be offered in sound-choice pop-ups unless they are the current choice"
+
+ ^ #('scrape' 'scritch' 'peaks')!
Item was added:
+ ----- Method: StandardScriptingSystem>>squeakyMouseForm (in category 'form dictionary') -----
+ squeakyMouseForm
+ ^ self formAtKey: 'squeakyMouse'
+
+ "
+ ScriptingSystem saveForm: (Form
+ extent: 30 at 29
+ depth: 16
+ fromArray: #( 1811114995 1878286257 2012637171 1811180532 1811180533 1811179508 1811180532 1811179508 1744006133 1878289396 1811180533 1878289396 1744007156 1674736630 1744006132 1811114995 1811181556 1744006131 1811246068 1811180532 1811179508 1811180532 1744071668 1811113972 1811180532 1811180532 1811179507 1878288338 1945529332 1744071668 1743941620 1811112945 1811179506 1811114995 1744006131 1744006130 1744005106 1811048434 1811113969 1743939570 1811179506 1743939571 1676833782 1676765171 1811047410 1744006131 1811048435 1811116020 1811180531 1743939571 1811048435 1743939570 1743939570 1743939570 1743940594 1744005106 1811181556 1811180532 1676766196 1743939570 1878420468 1676963830 1189896082 1811245044 1744137204 1744070644 1811179508 1811113971 1743939571 1811179508 1811246070 1811309524 1811302093 1811310580 1811246068 1674867703 1744049472 1120606594 1118465013 1744137205 1811179508 1811180532 1744071667 1744006132 1811112947 1811247095 1605584589 358761132 289435638 1676830707 1741975543 1462778473 1811312631 702891724 1811310548 1945528308 1811178450 1945528307 1878288372 1878353875 1878421494 1051471335 1809213397 1118524175 1811246068 1945659348 1185698607 1878486005 1672694510 1118531574 1607626741 1878420467 1811180533 1743942645 1744072693 1811301035 1185770487 1878486006 1324239597 1811180533 1811116019 1120623438 1878352818 1945462739 704868339 1878289395 1811049459 1878221808 1878223859 1743876083 1811162563 1945463796 1811181556 1464746666 1811116018 1809019893 1120551562 1945464821 1741844468 1466842760 1878289395 1811048434 1811050483 1811050483 1878223859 1049188174 1741910004 1811181556 1256998634 1811114994 1878289396 1466840647 1744007156 1744006131 1676877216 1743940596 1878222835 1743938545 1878351792 1676833781 358641652 1743940596 1811050484 845566798 1811113970 1811114995 1811163652 1811112913 1878420468 1878282028 1811179506 1607560178 1878289395 1676900342 1878351825 1466853330 1811113971 1811116019 635659217 1811179506 1811245045 1676942754 1744137206 1744201717 1676962806 1676962805 1811310581 1676896245 1744199635 1811376117 1744072695 1744005109 1811244019 499279861 1811310581 1811244020 1811293668 1399943159 1605528567 1744136181 982063522 986342388 1744070645 1744189066 430063308 1744071669 1744070644 1744067504 566519797 1744136181 1744137205 1743999854 912813044 1811311606 1742162607 4195488 283139922 1945531382 1253113857 144710948 1601400791 1811246069 1811167879 1464821747 1744136180 1674799094 1811178482 843473875 1811311606 1878533542 2106790 2080066222 1876193270 696845376 627472380 1185772536 1878355957 1743990309 1744007157 1676898294 1744006132 1811114996 1743941620 1811180533 1809204941 4194368 4217681 1878290421 1252982848 4194336 1670540278 1739811795 1878353906 1744006131 1811179506 1744007157 1744005106 1945462771 1811182582 1811311574 1393641133 1462856629 2012638196 1876382449 1112301394 1742041045 1945596917 1676833781 1811113970 1811179507 1811180532 1672705014 1674735606 1672697648 1945725943 1878551479 1809215479 1811312629 1809216504 1809215479 1809215478 1462853490 1878487029 1744007158 1744005075 1811239726 704979363 495004132 700789287 562372997 631646663 1739998892 4194400 1116497846 698688932 562375109 770124262 633609569 495070758 1257010166 562315916 1809279958 2012894002 1047280171 980237901 910966381 1668677696 4194400 6314867 1047281260 908804749 910968495 1393719290 1809279959 1185750370 1809214455 1878469062 423836236 1532188466 1601592148 1462986647 1672937568 4194368 6319062 1603622706 1601525554 1601522417 1047336194 770206679 1878487031 1878409899 977955830 1809145716 1118586509 980105834 980045584 1811372914 980104778 1605526483 1395605131 910769804 1118651052 1534358520 1809136234 1118596053 1532059506 1878485973 1326456163 1945660374 1742106615 1811311607 1945725942 1742107641 1744072693 1811311605 1744203767 1878551543 564478604 1878553591 1603428242 1811048433 1811049459 1051290611 1744006131 1811049459 1878156273 1743874034 1744007156 1743874033 1811048434 1811113970 1743939571 1743933228 1603301363 1743875059 1811049458 1945461745 1811181556 1811113971 1811049458 1811048434 1811116020 1878287346 1878223857 1743940594 1744006130 1744007157 1945395153 1945400309 1811048434 1743810547 1676765170 1878353906 1811113970 1743874032 1810983921 1743874033 1811113971 1676765169 1743874034 1743940593 1743939569 1811047409 1676765168 1743940595 1810981872 1945397235 1607560179 1743941620 1810982897 1810983921 1811048433 1744007155 1743875059 1811048434 1743875058 1743939568 1676832754 1811116019 1811114994 1811244019 1676962805 1677029367 1811244020 1744005106 1743940594 1811246068 1744070645 1676961781 1744004084 1676897269 1811180533 1878353908 1744004083 1744070645)
+ offset: 0 at 0) atKey: 'squeakyMouse'"!
Item was added:
+ ----- Method: StandardScriptingSystem>>stripGraphicsForExternalRelease (in category 'utilities') -----
+ stripGraphicsForExternalRelease
+ "ScriptingSystem stripGraphicsForExternalRelease"
+
+ | replacement |
+ replacement := FormDictionary at: #Gets.
+
+ #('BadgeMiniPic' 'BadgePic' 'Broom' 'CedarPic' 'CollagePic' 'CoverMain' 'CoverSpiral' 'CoverTexture' 'Fred' 'ImagiPic' 'KayaPic' 'StudioPic')
+ do:
+ [:aKey | FormDictionary at: aKey asSymbol put: replacement]!
Item was added:
+ MorphicAlarm subclass: #StepMessage
+ instanceVariableNames: 'stepTime'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: StepMessage class>>scheduledAt:stepTime:receiver:selector:arguments: (in category 'instance creation') -----
+ scheduledAt: scheduledTime stepTime: stepTime receiver: aTarget selector: aSelector arguments: argArray
+ ^(self receiver: aTarget selector: aSelector arguments: argArray)
+ scheduledTime: scheduledTime;
+ stepTime: stepTime!
Item was added:
+ ----- Method: StepMessage>>printOn: (in category 'printing') -----
+ printOn: aStream
+ super printOn: aStream.
+ aStream
+ nextPut: $(;
+ print: receiver;
+ space;
+ print: selector;
+ space;
+ print: scheduledTime;
+ nextPut: $).!
Item was added:
+ ----- Method: StepMessage>>stepTime (in category 'testing') -----
+ stepTime
+ "Return the step time for this message. If nil, the receiver of the message will be asked for its #stepTime."
+ ^stepTime!
Item was added:
+ ----- Method: StepMessage>>stepTime: (in category 'accessing') -----
+ stepTime: aNumber
+ "Set the step time for this message. If nil, the receiver of the message will be asked for its #stepTime."
+ stepTime := aNumber!
Item was added:
+ ----- Method: String>>asMorph (in category '*Morphic') -----
+ asMorph
+ "Answer the receiver as a StringMorph"
+
+ ^ StringMorph contents: self
+
+ "'bugs black blood' asMorph openInHand"!
Item was added:
+ ----- Method: String>>asStringMorph (in category '*Morphic') -----
+ asStringMorph
+ "Answer the receiver as a StringMorph"
+
+ ^ StringMorph contents: self
+
+ "'bugs black blood' asStringMorph openInHand"!
Item was added:
+ ----- Method: String>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
+ hasContentsInExplorer
+
+ ^false!
Item was added:
+ ----- Method: String>>openAsMorph (in category '*Morphic-converting') -----
+ openAsMorph
+ "Open the receiver as a morph"
+
+ ^ self asMorph openInHand !
Item was added:
+ Morph subclass: #StringMorph
+ instanceVariableNames: 'font emphasis contents hasFocus'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !StringMorph commentStamp: 'efc 3/7/2003 17:34' prior: 0!
+ StringMorph is a "lightweight" Morph to display a String. It supports only a single font, color, and emphasis combination. For multiple text styles, use TextMorph.
+
+ Structure:
+ instance var Type Description
+ font StrikeFont (normally nil; then the accessor #font gives back TextStyle
+ or nil defaultFont)
+ emphasis SmallInteger bitmask determining character attributes (underline, bold, italics, narrow, struckout)
+ contents String The text that will be displayed.
+ hasFocus Boolean Do I have the keyboard focus or not?
+
+ If you shift-click on a StringMorph you can edit its string. This is accomplished the following way: StringMorph can launch a StringMorphEditor if it receives a #mouseDown event.
+
+ A StringMorph may also be used like a SimpleButtonMorph to do an action when clicked. Use the menu 'extras' / 'add mouseUpAction'.
+
+ The following propery will be defined:
+ aStringMorph valueOfProperty: #mouseUpCodeToRun!
Item was added:
+ ----- Method: StringMorph class>>authoringPrototype (in category 'scripting') -----
+ authoringPrototype
+ ^ super authoringPrototype contents: 'String'!
Item was added:
+ ----- Method: StringMorph class>>contents: (in category 'instance creation') -----
+ contents: aString
+ " 'StringMorph contents: str' is faster than 'StringMorph new contents: str' "
+ ^ self contents: aString font: nil!
Item was added:
+ ----- Method: StringMorph class>>contents:font: (in category 'instance creation') -----
+ contents: aString font: aFont
+ ^ self basicNew initWithContents: aString font: aFont emphasis: 0!
Item was added:
+ ----- Method: StringMorph class>>contents:font:emphasis: (in category 'instance creation') -----
+ contents: aString font: aFont emphasis: emphasisCode
+ ^ self basicNew initWithContents: aString font: aFont emphasis: emphasisCode!
Item was added:
+ ----- Method: StringMorph class>>test (in category 'testing') -----
+ test
+ "Return a morph with lots of strings for testing display speed."
+ | c |
+ c := AlignmentMorph newColumn.
+ SystemOrganization categories do:
+ [:cat | c addMorph: (StringMorph new contents: cat)].
+ ^ c!
Item was added:
+ ----- Method: StringMorph class>>test2 (in category 'testing') -----
+ test2
+ "Return a morph with lots of strings for testing display speed."
+ | c r |
+ c := AlignmentMorph newColumn.
+ SystemOrganization categories reverseDo:
+ [:cat | c addMorph: (StringMorph new contents: cat)].
+ r := RectangleMorph new extent: c fullBounds extent.
+ c submorphsDo: [:m | r addMorph: m].
+ ^ r
+ !
Item was added:
+ ----- Method: StringMorph>>acceptContents (in category 'editing') -----
+ acceptContents
+ "The message is sent when the user hits enter or Cmd-S. Accept the current contents and end editing. This default implementation does nothing."
+ !
Item was added:
+ ----- Method: StringMorph>>acceptValue: (in category 'editing') -----
+ acceptValue: aValue
+ | val |
+ self contents: (val := aValue asString).
+ ^ val!
Item was added:
+ ----- Method: StringMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu add: 'change font' translated action: #changeFont.
+ aCustomMenu add: 'change emphasis' translated action: #changeEmphasis.
+ !
Item was added:
+ ----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
+ addOptionalHandlesTo: aHalo box: box
+ self flag: #deferred.
+
+ "Eventually...
+ self addFontHandlesTo: aHalo box: box"!
Item was added:
+ ----- Method: StringMorph>>boundsForBalloon (in category 'halos and balloon help') -----
+ boundsForBalloon
+ "Some morphs have bounds that are way too big. This is a contorted way of making things work okay in PluggableListMorphs, whose list elements historically have huge widths"
+
+ | ownerOwner |
+ ^ ((owner notNil and: [(ownerOwner := owner owner) notNil]) and:
+ [ownerOwner isKindOf: PluggableListMorph])
+ ifTrue:
+ [self boundsInWorld intersect: ownerOwner boundsInWorld]
+ ifFalse:
+ [super boundsForBalloon]!
Item was added:
+ ----- Method: StringMorph>>cancelEdits (in category 'editing') -----
+ cancelEdits
+
+ self doneWithEdits!
Item was added:
+ ----- Method: StringMorph>>changeEmphasis (in category 'menu') -----
+ changeEmphasis
+
+ | reply aList |
+ aList := #(normal bold italic narrow underlined struckOut).
+ reply := UIManager default
+ chooseFrom: (aList collect: [:t | t translated])
+ values: aList..
+ reply ifNotNil:[
+ self emphasis: (TextEmphasis perform: reply) emphasisCode.
+ ].
+ !
Item was added:
+ ----- Method: StringMorph>>changeFont (in category 'menu') -----
+ changeFont
+
+ | chooser originalFont |
+ originalFont := self fontToUse.
+ self openModal: (
+ Cursor wait showWhile: [
+ | window |
+ window := UIManager default
+ chooseFont: 'Choose a Font'
+ for: self
+ setSelector: #font:
+ getSelector: originalFont.
+ "We have to save the model here, because it will be gone when the window is closed."
+ chooser := window model.
+ window ]).
+ originalFont = self fontToUse ifFalse: [
+ "Ensure that we restore the original font in case it was changed, but Cancel was clicked."
+ self font: (chooser result ifNil: [ originalFont ]) ]!
Item was added:
+ ----- Method: StringMorph>>contents (in category 'accessing') -----
+ contents
+
+ ^ contents!
Item was added:
+ ----- Method: StringMorph>>contents: (in category 'accessing') -----
+ contents: newContents
+ | scanner |
+ contents := newContents isText
+ ifTrue: [scanner := StringMorphAttributeScanner new initializeFromStringMorph: self.
+ (newContents attributesAt: 1 forStyle: self font textStyle)
+ do: [:attr | attr emphasizeScanner: scanner].
+ emphasis := scanner emphasis.
+ font := scanner font.
+ color := scanner textColor.
+ newContents string]
+ ifFalse: [contents = newContents
+ ifTrue: [^ self].
+ "no substantive change"
+ newContents].
+ self fitContents!
Item was added:
+ ----- Method: StringMorph>>contentsClipped: (in category 'accessing') -----
+ contentsClipped: aString
+ "Change my text, but do not change my size as a result"
+ contents = aString ifTrue: [^ self]. "No substantive change"
+ contents := aString.
+ self changed!
Item was added:
+ ----- Method: StringMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color black!
Item was added:
+ ----- Method: StringMorph>>doneWithEdits (in category 'editing') -----
+ doneWithEdits
+
+ hasFocus := false!
Item was added:
+ ----- Method: StringMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ aCanvas drawString: contents in: bounds font: self fontToUse color: color.!
Item was added:
+ ----- Method: StringMorph>>emphasis: (in category 'font') -----
+ emphasis: aNumber
+ "Set the receiver's emphasis as indicated. aNumber is a bitmask with the following format:
+
+ bit attribute
+ 1 bold
+ 2 italic
+ 4 underlined
+ 8 narrow
+ 16 struckOut"
+
+ "examples: 0 -> plain.
+ 1 -> bold. 2 -> italic. 3 -> bold italic. 4 -> underlined
+ 5 -> bold underlined. 6 -> italic underlined. 7 -> bold italic underlined
+ etc..."
+
+ emphasis := aNumber.
+ ^ self font: font emphasis: emphasis!
Item was added:
+ ----- Method: StringMorph>>fitContents (in category 'accessing') -----
+ fitContents
+
+ | newBounds boundsChanged |
+ newBounds := self measureContents.
+ boundsChanged := bounds extent ~= newBounds.
+ self extent: newBounds. "default short-circuits if bounds not changed"
+ boundsChanged ifFalse: [self changed]!
Item was added:
+ ----- Method: StringMorph>>fixUponLoad:seg: (in category 'objects from disk') -----
+ fixUponLoad: aProject seg: anImageSegment
+ "We are in an old project that is being loaded from disk.
+ Fix up conventions that have changed."
+
+ | substituteFont |
+ substituteFont := aProject projectParameters at:
+ #substitutedFont ifAbsent: [#none].
+ (substituteFont ~~ #none and: [self font == substituteFont])
+ ifTrue: [ self fitContents ].
+
+ ^ super fixUponLoad: aProject seg: anImageSegment!
Item was added:
+ ----- Method: StringMorph>>font (in category 'accessing') -----
+ font
+ "who came up with #fontToUse rather than font?!!"
+ ^self fontToUse!
Item was added:
+ ----- Method: StringMorph>>font: (in category 'printing') -----
+ font: aFont
+ "Set the font my text will use. The emphasis remains unchanged."
+
+ font := aFont.
+ ^ self font: font emphasis: emphasis!
Item was added:
+ ----- Method: StringMorph>>font:emphasis: (in category 'accessing') -----
+ font: aFont emphasis: emphasisCode
+ font := aFont.
+ emphasis := emphasisCode.
+ self fitContents.
+ "
+ in inspector say,
+ self font: (TextStyle default fontAt: 2) emphasis: 1
+ "!
Item was added:
+ ----- Method: StringMorph>>fontName:size: (in category 'accessing') -----
+ fontName: fontName size: fontSize
+
+ ^ self font: (StrikeFont familyName: fontName size: fontSize)
+ emphasis: 0!
Item was added:
+ ----- Method: StringMorph>>fontToUse (in category 'accessing') -----
+ fontToUse
+ | fontToUse |
+ fontToUse := font isNil ifTrue: [TextStyle defaultFont] ifFalse: [font].
+ (emphasis isNil or: [emphasis = 0])
+ ifTrue: [^fontToUse]
+ ifFalse: [^fontToUse emphasized: emphasis]!
Item was added:
+ ----- Method: StringMorph>>fullBounds (in category 'layout') -----
+ fullBounds
+ self contents ifNil: [ self contents: 'String Morph' ].
+ ^super fullBounds!
Item was added:
+ ----- Method: StringMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ ^ (evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick])
+ ifTrue: [true]
+ ifFalse: [super handlesMouseDown: evt].
+ !
Item was added:
+ ----- Method: StringMorph>>hasFocus (in category 'event handling') -----
+ hasFocus
+ ^ hasFocus!
Item was added:
+ ----- Method: StringMorph>>hasTranslucentColor (in category 'accessing') -----
+ hasTranslucentColor
+
+ ^true!
Item was added:
+ ----- Method: StringMorph>>imageForm:forRectangle: (in category 'drawing') -----
+ imageForm: depth forRectangle: rect
+ | canvas |
+ canvas := Display defaultCanvasClass extent: rect extent depth: depth.
+ canvas form fillColor: self color negated.
+ canvas translateBy: rect topLeft negated
+ during:[:tempCanvas| tempCanvas fullDrawMorph: self].
+ ^ canvas form offset: rect topLeft!
Item was added:
+ ----- Method: StringMorph>>initWithContents:font:emphasis: (in category 'initialization') -----
+ initWithContents: aString font: aFont emphasis: emphasisCode
+ super initialize.
+
+ font := aFont.
+ emphasis := emphasisCode.
+ hasFocus := false.
+ self contents: aString!
Item was added:
+ ----- Method: StringMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+ font := nil.
+ emphasis := 0.
+ hasFocus := false!
Item was added:
+ ----- Method: StringMorph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ super initializeToStandAlone.
+
+ font := nil.
+ emphasis := 0.
+ hasFocus := false.
+ self contents: 'String: Shift-click on me to edit'!
Item was added:
+ ----- Method: StringMorph>>interimContents: (in category 'accessing') -----
+ interimContents: aString
+ "The receiver is under edit and aString represents the string the user sees as she edits, which typically will not have been accepted and indeed may be abandoned"
+
+ self contents: aString!
Item was added:
+ ----- Method: StringMorph>>label:font: (in category 'accessing') -----
+ label: aString font: aFont
+ "compatible protocol used in ScriptEditorMorph>>bringUpToDate"
+ self contents: aString.
+ self font: aFont!
Item was added:
+ ----- Method: StringMorph>>launchMiniEditor: (in category 'editing') -----
+ launchMiniEditor: evt
+
+ | textMorph |
+ hasFocus := true. "Really only means edit in progress for this morph"
+ textMorph := StringMorphEditor new contentsAsIs: contents.
+ textMorph beAllFont: self fontToUse.
+ textMorph bounds: (self bounds expandBy: 0 at 2).
+ self addMorphFront: textMorph.
+ evt hand newKeyboardFocus: textMorph.
+ textMorph editor selectFrom: 1 to: textMorph paragraph text string size!
Item was added:
+ ----- Method: StringMorph>>lookTranslucent (in category 'drawing') -----
+ lookTranslucent
+
+ "keep the text the same color (black)"!
Item was added:
+ ----- Method: StringMorph>>lostFocusWithoutAccepting (in category 'editing') -----
+ lostFocusWithoutAccepting
+ "The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus -- typically by clicking on some editable text somewhere else -- without having accepted the current edits."
+
+ self acceptContents!
Item was added:
+ ----- Method: StringMorph>>measureContents (in category 'accessing') -----
+ measureContents
+ | f |
+ f := self fontToUse.
+ ^(((f widthOfString: contents) max: self minimumWidth) @ f height).!
Item was added:
+ ----- Method: StringMorph>>minHeight (in category 'connectors-layout') -----
+ minHeight
+ "answer the receiver's minHeight"
+ ^ super minHeight max: self fontToUse height!
Item was added:
+ ----- Method: StringMorph>>minimumWidth (in category 'accessing') -----
+ minimumWidth
+ "Answer the minimum width that the receiver can have. A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!! Obeyed by fitContents."
+
+ ^ 3!
Item was added:
+ ----- Method: StringMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "If the shift key is pressed, make this string the keyboard input focus."
+
+ (evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick])
+ ifTrue: [self launchMiniEditor: evt]
+ ifFalse: [super mouseDown: evt].
+ !
Item was added:
+ ----- Method: StringMorph>>printOn: (in category 'printing') -----
+ printOn: aStream
+
+ super printOn: aStream.
+ aStream print: contents.
+ !
Item was added:
+ ----- Method: StringMorph>>setWidth: (in category 'accessing') -----
+ setWidth: width
+
+ self extent: width @ (font ifNil: [TextStyle defaultFont]) height!
Item was added:
+ ----- Method: StringMorph>>userString (in category 'accessing') -----
+ userString
+ "Do I have a text string to be searched on?"
+
+ ^ contents!
Item was added:
+ ----- Method: StringMorph>>valueFromContents (in category 'accessing') -----
+ valueFromContents
+ "Return a new value from the current contents string."
+ ^ contents!
Item was added:
+ ----- Method: StringMorph>>wantsKeyboardFocusOnShiftClick (in category 'editing') -----
+ wantsKeyboardFocusOnShiftClick
+ ^ owner topRendererOrSelf wantsKeyboardFocusFor: self
+ !
Item was added:
+ ----- Method: StringMorph>>wouldAcceptKeyboardFocus (in category 'event handling') -----
+ wouldAcceptKeyboardFocus
+ ^ self isLocked not!
Item was added:
+ Object subclass: #StringMorphAttributeScanner
+ instanceVariableNames: 'fontNumber textColor emphasis alignment actualFont indent kern'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !StringMorphAttributeScanner commentStamp: '<historical>' prior: 0!
+ A StringMorphAttributeScanner provides the interface of a CharacterScanner so that text attributes may be collected from a Text and used elsewhere, like in setting the attributes of a StringMorph.
+ !
Item was added:
+ ----- Method: StringMorphAttributeScanner>>actualFont (in category 'accessing') -----
+ actualFont
+ "Answer the value of actualFont"
+
+ ^ actualFont ifNil: [ TextStyle defaultFont ]!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>addEmphasis: (in category 'scanning') -----
+ addEmphasis: anInteger
+ "Set the value of emphasis"
+
+ emphasis := emphasis bitOr: anInteger!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>addKern: (in category 'scanning') -----
+ addKern: kernDelta
+ "Set the current kern amount."
+ kern := kern + kernDelta!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>alignment (in category 'accessing') -----
+ alignment
+ "Answer the value of alignment"
+
+ ^ alignment!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>emphasis (in category 'accessing') -----
+ emphasis
+ "Answer the value of emphasis"
+
+ ^ emphasis!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>font (in category 'accessing') -----
+ font
+ "Answer the value of font"
+
+ ^self textStyle fontAt: self fontNumber!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>fontNumber (in category 'accessing') -----
+ fontNumber
+ "Answer the value of font"
+
+ ^ fontNumber!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>indent (in category 'accessing') -----
+ indent
+ "Answer the value of indent"
+
+ ^ indent!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>indentationLevel: (in category 'scanning') -----
+ indentationLevel: anInteger
+ "Set the value of indent"
+
+ indent := anInteger!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>initialize (in category 'initialize-release') -----
+ initialize
+ emphasis := 0.
+ indent := 0.
+ kern := 0.
+ fontNumber := 1.
+ actualFont := TextStyle defaultFont!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>initializeFromStringMorph: (in category 'string morph') -----
+ initializeFromStringMorph: aStringMorph
+ | style |
+ actualFont := aStringMorph font ifNil: [ TextStyle defaultFont ].
+ style := actualFont textStyle.
+ emphasis := actualFont emphasis.
+ fontNumber := (style fontIndexOf: actualFont) ifNil: [ 1 ].
+ textColor := aStringMorph color.
+ !
Item was added:
+ ----- Method: StringMorphAttributeScanner>>kern (in category 'accessing') -----
+ kern
+ "Answer the value of kern"
+
+ ^ kern!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>setActualFont: (in category 'scanning') -----
+ setActualFont: aFont
+ "Set the value of actualFont, from a TextFontReference"
+
+ actualFont := aFont.
+ aFont textStyle ifNotNil: [ :ts | fontNumber := ts fontIndexOf: aFont ]!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>setAlignment: (in category 'scanning') -----
+ setAlignment: aSymbol
+ "Set the value of alignment"
+
+ alignment := aSymbol!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>setFont: (in category 'scanning') -----
+ setFont: fontNum
+ "Set the value of font"
+
+ fontNumber := fontNum!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>textColor (in category 'accessing') -----
+ textColor
+ "Answer the value of textColor"
+
+ ^ textColor!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>textColor: (in category 'scanning') -----
+ textColor: anObject
+ "Set the value of textColor"
+
+ textColor := anObject!
Item was added:
+ ----- Method: StringMorphAttributeScanner>>textStyle (in category 'accessing') -----
+ textStyle
+ ^self actualFont textStyle ifNil: [ TextStyle default ]!
Item was added:
+ TextMorph subclass: #StringMorphEditor
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !StringMorphEditor commentStamp: '<historical>' prior: 0!
+ I am a textMorph used as a pop-up editor for StringMorphs. I present a yellow background and I go away when a CR is typed or when the user clicks elsewhere.!
Item was added:
+ ----- Method: StringMorphEditor class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ "Not to be instantiated from the menu"
+ ^ false!
Item was added:
+ ----- Method: StringMorphEditor>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ aCanvas fillRectangle: self bounds color: Color yellow muchLighter.
+ ^ super drawOn: aCanvas!
Item was added:
+ ----- Method: StringMorphEditor>>initialize (in category 'display') -----
+ initialize
+ "Initialize the receiver. Give it a white background"
+
+ super initialize.
+ self backgroundColor: Color white.
+ self color: Color red!
Item was added:
+ ----- Method: StringMorphEditor>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+ "This is hugely inefficient, but it seems to work, and it's unlikely it will ever need
+ to be any more efficient -- it's only intended to edit single-line strings."
+
+ | char priorEditor newSel |
+ (((char := evt keyCharacter) = Character enter) or: [(char = Character cr)
+ or: [char = $s and: [evt commandKeyPressed]]])
+ ifTrue: [owner doneWithEdits; acceptContents.
+ self flag: #arNote. "Probably unnecessary"
+ evt hand releaseKeyboardFocus.
+ ^ self delete].
+
+ (char = $l and: [evt commandKeyPressed]) ifTrue: "cancel"
+ [owner cancelEdits.
+ evt hand releaseKeyboardFocus.
+ ^ self delete].
+
+ super keyStroke: evt.
+ owner interimContents: self contents asString.
+ newSel := self editor selectionInterval.
+
+ priorEditor := self editor. "Save editor state"
+ self releaseParagraph. "Release paragraph so it will grow with selection."
+ self paragraph. "Re-instantiate to set new bounds"
+ self installEditorToReplace: priorEditor. "restore editor state"
+ self editor selectFrom: newSel first to: newSel last.
+ !
Item was added:
+ ----- Method: StringMorphEditor>>keyboardFocusChange: (in category 'event handling') -----
+ keyboardFocusChange: aBoolean
+ | hadFocus |
+ owner ifNil: [ ^self ].
+ hadFocus := owner hasFocus.
+ super keyboardFocusChange: aBoolean.
+ aBoolean ifFalse:
+ [hadFocus ifTrue:
+ [owner lostFocusWithoutAccepting; doneWithEdits].
+ ^ self delete]!
Item was added:
+ FileDirectoryWrapper subclass: #SuperSwikiDirectoryWrapper
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Explorer'!
+
+ !SuperSwikiDirectoryWrapper commentStamp: '<historical>' prior: 0!
+ The super swiki does not at present have subdirectories!
Item was added:
+ ----- Method: SuperSwikiDirectoryWrapper>>contents (in category 'as yet unclassified') -----
+ contents
+
+ ^#() "we have no sundirectories"!
Item was added:
+ ----- Method: SuperSwikiDirectoryWrapper>>hasContents (in category 'as yet unclassified') -----
+ hasContents
+
+ ^false "we have no sundirectories"!
Item was added:
+ ----- Method: SyntaxError class>>buildMorphicViewOn: (in category '*Morphic-Support') -----
+ buildMorphicViewOn: aSyntaxError
+ "Answer an Morphic view on the given SyntaxError."
+ | window |
+ window := (SystemWindow labelled: 'Syntax Error') model: aSyntaxError.
+
+ window addMorph: (PluggableListMorph on: aSyntaxError list: #list
+ selected: #listIndex changeSelected: nil menu: #listMenu:)
+ frame: (0 at 0 corner: 1 at 0.15).
+
+ window addMorph: (PluggableTextMorph on: aSyntaxError text: #contents
+ accept: #contents:notifying: readSelection: #contentsSelection
+ menu: #codePaneMenu:shifted:)
+ frame: (0 at 0.15 corner: 1 at 1).
+
+ ^ window openInWorldExtent: 380 at 220!
Item was added:
+ ----- Method: SyntaxError class>>morphicOpen: (in category '*Morphic-Support') -----
+ morphicOpen: aSyntaxError
+ "Answer a view whose model is an instance of me."
+
+ self buildMorphicViewOn: aSyntaxError.
+ Project current spawnNewProcessIfThisIsUI: Processor activeProcess.
+ ^ Processor activeProcess suspend!
Item was added:
+ RectangleMorph subclass: #SystemProgressBarMorph
+ instanceVariableNames: 'barSize'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !SystemProgressBarMorph commentStamp: 'laza 4/9/2004 11:47' prior: 0!
+ Instances of this morph get used by SystemProgressMoprh to quickly display a progress bar.!
Item was added:
+ ----- Method: SystemProgressBarMorph>>barSize: (in category 'accessing') -----
+ barSize: anInteger
+ barSize := anInteger.
+ self changed.!
Item was added:
+ ----- Method: SystemProgressBarMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | area |
+ super drawOn: aCanvas.
+
+ barSize > 0 ifTrue: [
+ area := self innerBounds.
+ area := area origin extent: barSize-2 at area extent y.
+ aCanvas fillRectangle: area color: LazyListMorph listSelectionColor
+ ].
+ !
Item was added:
+ ----- Method: SystemProgressBarMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+
+ self
+ borderWidth: 0;
+ color: Preferences menuColor muchLighter.
+
+ barSize := 0.
+ !
Item was added:
+ RectangleMorph subclass: #SystemProgressMorph
+ instanceVariableNames: 'activeSlots bars labels font lock requestedPosition'
+ classVariableNames: 'BarHeight BarWidth Inset UniqueInstance'
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !SystemProgressMorph commentStamp: '<historical>' prior: 0!
+ An single instance of this morph class is used to display progress while the system is busy, eg. while it receives code updates or does a fileIn. To give the user progress information you don't deal directly with SystemProgressMorph. You keep on using the well established way of progress notification, that has been a long time in the system, is widely used and does not depend on the existence of SystemProgressMorph. For more information on this look at the example in this class or look at the comment of the method displayProgressAt:from:to:during: in class String.
+
+ SystemProgressMorph is not meant to be used as a component inside other morphs.
+
+ You can switch back to the old style of progress display by disabling the morphicProgressStyle setting in the morphic section of the preferences.!
Item was added:
+ ----- Method: SystemProgressMorph class>>close: (in category 'instance creation') -----
+ close: aBlock
+ | slot |
+ slot := aBlock value: SmallInteger maxVal. "This should prevent a redraw"
+ aBlock receiver freeSlot: slot.
+
+ !
Item was added:
+ ----- Method: SystemProgressMorph class>>example (in category 'examples') -----
+ example
+ "SystemProgressMorph example"
+ 'Progress'
+ displayProgressFrom: 0 to: 1000
+ during: [:bar | 0 to: 1000 do: [:i | bar value: i. (Delay forMilliseconds: 2) wait]]
+ !
Item was added:
+ ----- Method: SystemProgressMorph class>>exampleChangeLabel (in category 'examples') -----
+ exampleChangeLabel
+ "SystemProgressMorph exampleChangeLabel"
+ | classes |
+ classes := Smalltalk allClasses copyFrom: 1 to: 100.
+ 'InitialLabel'
+ displayProgressFrom: 0 to: classes size
+ during: [:bar | 1 to: classes size do: [:i |
+ bar value: i.
+ bar value: i printString, '/', classes size printString, ' ', (classes at: i) printString.
+ (Delay forMilliseconds: 100) wait]]
+ !
Item was added:
+ ----- Method: SystemProgressMorph class>>exampleLabelOnly (in category 'examples') -----
+ exampleLabelOnly
+ "SystemProgressMorph exampleLabelOnly"
+ | words |
+ words := #(zero one two three four five six seven eight nine ten) reversed.
+ UIManager default informUserDuring: [:bar |
+ words do: [:each|
+ bar value: 'Countdown: ', each.
+ (Delay forSeconds: 1) wait]].!
Item was added:
+ ----- Method: SystemProgressMorph class>>informUserAt:during: (in category 'instance creation') -----
+ informUserAt: aPoint during: workBlock
+ ProgressInitiationException
+ display: ' '
+ at: aPoint
+ from: 0
+ to: 0
+ during: workBlock!
Item was added:
+ ----- Method: SystemProgressMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "SystemProgressMorph initialize; reset"
+ BarHeight := 8.
+ BarWidth := 300.
+ Inset := 30 at 30!
Item was added:
+ ----- Method: SystemProgressMorph class>>label:min:max: (in category 'instance creation') -----
+ label: shortDescription min: minValue max: maxValue
+ "This method is no longer used, but kept for a while longer to ensure no difficulties updating via the trunk."
+ ^ self
+ position: Display center
+ label: shortDescription
+ min: minValue
+ max: maxValue!
Item was added:
+ ----- Method: SystemProgressMorph class>>new (in category 'instance creation') -----
+ new
+ ^self shouldNotImplement!
Item was added:
+ ----- Method: SystemProgressMorph class>>position:label:min:max: (in category 'instance creation') -----
+ position: aPoint label: shortDescription min: minValue max: maxValue
+ UniqueInstance ifNil: [ UniqueInstance := super new ].
+ ^ UniqueInstance
+ position: aPoint
+ label: (shortDescription contractTo: 100)
+ min: minValue asFloat
+ max: maxValue asFloat!
Item was added:
+ ----- Method: SystemProgressMorph class>>reset (in category 'instance creation') -----
+ reset
+ "SystemProgressMorph reset"
+ UniqueInstance ifNotNil: [UniqueInstance delete].
+ UniqueInstance := nil.!
Item was added:
+ ----- Method: SystemProgressMorph class>>uniqueInstance (in category 'instance creation') -----
+ uniqueInstance
+ ^UniqueInstance ifNil:[super new]!
Item was added:
+ ----- Method: SystemProgressMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
+ dismissViaHalo
+ self class reset!
Item was added:
+ ----- Method: SystemProgressMorph>>freeSlot: (in category 'private') -----
+ freeSlot: number
+ number > 0 ifFalse: [^self].
+ lock critical: [| label |
+ label := labels at: number.
+ (label isNil or: [label owner isNil]) ifTrue: [^self]. "Has been freed before"
+ label delete.
+ (bars at: number) delete.
+ activeSlots := activeSlots - 1.
+ activeSlots = 0
+ ifTrue: [self delete]
+ ifFalse: [self reposition]]!
Item was added:
+ ----- Method: SystemProgressMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ activeSlots := 0.
+ bars := Array new: 10.
+ labels := Array new: 10.
+ font := Preferences standardMenuFont.
+ lock := Semaphore forMutualExclusion.
+ self setDefaultParameters;
+ setProperty: #morphicLayerNumber toValue: self morphicLayerNumber;
+ layoutPolicy: TableLayout new;
+ listDirection: #topToBottom;
+ cellPositioning: #leftCenter;
+ cellInset: 5;
+ listCentering: #center;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ layoutInset: Inset;
+ minWidth: 150!
Item was added:
+ ----- Method: SystemProgressMorph>>label:min:max: (in category 'private') -----
+ label: shortDescription min: minValue max: maxValue
+ | slot range barSize lastRefresh |
+ "This method is no longer used, but kept for a while longer to ensure no difficulties updating via the trunk."
+ ((range := maxValue - minValue) < 0 or: [(slot := self nextSlotFor: shortDescription) = 0])
+ ifTrue: [^[:barVal| 0 ]].
+ range <= 0 ifTrue: [self removeMorph: (bars at: slot)].
+ self recenter.
+ self openInWorld.
+ barSize := -1. "Enforces a inital draw of the morph"
+ lastRefresh := 0.
+ ^[:barVal | | newBarSize |
+ barVal isString ifTrue: [
+ self setLabel: barVal at: slot.
+ self currentWorld displayWorld].
+ (barVal isNumber and: [range >= 1 and: [barVal between: minValue and: maxValue]]) ifTrue: [
+ newBarSize := (barVal - minValue / range * BarWidth) truncated.
+ newBarSize = barSize ifFalse: [
+ barSize := newBarSize.
+ (bars at: slot) barSize: barSize.
+ Time primMillisecondClock - lastRefresh > 25 ifTrue: [
+ self currentWorld displayWorld.
+ lastRefresh := Time primMillisecondClock]]].
+ slot]
+ !
Item was added:
+ ----- Method: SystemProgressMorph>>labelAt:put: (in category 'labelling') -----
+ labelAt: progressBlock put: aString
+ "Change the label for the given progressBlock to aString."
+ progressBlock value: aString!
Item was added:
+ ----- Method: SystemProgressMorph>>morphicLayerNumber (in category 'initialization') -----
+ morphicLayerNumber
+ "progress morphs are behind menus and balloons, but in front of most other stuff"
+ ^self valueOfProperty: #morphicLayerNumber ifAbsent: [12].
+ !
Item was added:
+ ----- Method: SystemProgressMorph>>nextSlotFor: (in category 'private') -----
+ nextSlotFor: shortDescription
+
+ lock critical: [ | label bar slots |
+ slots := labels size.
+ activeSlots = slots ifTrue: [^0].
+ activeSlots := activeSlots + 1.
+ 1 to: slots do: [:index |
+ label := (labels at: index).
+ label ifNil: [
+ bar := bars at: index put: (SystemProgressBarMorph new extent: BarWidth at BarHeight).
+ label := labels at: index put: (StringMorph contents: shortDescription font: font).
+ self
+ addMorphBack: label;
+ addMorphBack: bar.
+ ^index].
+ label owner ifNil: [
+ bar := bars at: index.
+ label := labels at: index.
+ self
+ addMorphBack: (label contents: shortDescription);
+ addMorphBack: (bar barSize: 0).
+ ^index]]]
+ !
Item was added:
+ ----- Method: SystemProgressMorph>>position:label:min:max: (in category 'private') -----
+ position: aPoint label: shortDescription min: minValue max: maxValue
+ | slot range barSize lastRefresh |
+ requestedPosition := aPoint.
+ ((range := maxValue - minValue) < 0 or: [(slot := self nextSlotFor: shortDescription) = 0])
+ ifTrue: [^[:barVal| 0 ]].
+ range <= 0 ifTrue: [self removeMorph: (bars at: slot)].
+ self reposition.
+ self openInWorld.
+ barSize := -1. "Enforces a inital draw of the morph"
+ lastRefresh := 0.
+ ^[:barVal | | newBarSize |
+ barVal isString ifTrue: [
+ self setLabel: barVal at: slot.
+ self currentWorld displayWorld].
+ (barVal isNumber and: [range >= 1 and: [barVal between: minValue and: maxValue]]) ifTrue: [
+ newBarSize := (barVal - minValue / range * BarWidth) truncated.
+ newBarSize = barSize ifFalse: [
+ barSize := newBarSize.
+ (bars at: slot) barSize: barSize.
+ Time primMillisecondClock - lastRefresh > 25 ifTrue: [
+ self currentWorld displayWorld.
+ lastRefresh := Time primMillisecondClock]]].
+ slot]
+ !
Item was added:
+ ----- Method: SystemProgressMorph>>recenter (in category 'private') -----
+ recenter
+ | position |
+ "This method is no longer used, but kept for a while longer to ensure no difficulties updating via the trunk."
+ "Put ourself in the center of the display"
+ self align: self fullBounds center with: Display boundingBox center.
+ "Check to see if labels are wider than progress bars. In that case do
+ a centered instead of the default left aligned layout."
+ position := self width > (Inset x * 2 + (self borderWidth * 2) + BarWidth)
+ ifTrue: [#topCenter]
+ ifFalse: [#leftCenter].
+ self cellPositioning: position!
Item was added:
+ ----- Method: SystemProgressMorph>>reposition (in category 'private') -----
+ reposition
+ "Put ourself in the requested position on the display, but ensure completely within the bounds of the display"
+ | position |
+ self bounds:
+ ((self fullBounds
+ align: self fullBounds center
+ with: (requestedPosition ifNil: [ self fullBounds center ])) translatedToBeWithin: Display boundingBox).
+ "Check to see if labels are wider than progress bars. In that case do
+ a centered instead of the default left aligned layout."
+ position := self width > (Inset x * 2 + (self borderWidth * 2) + BarWidth)
+ ifTrue: [ #topCenter ]
+ ifFalse: [ #leftCenter ].
+ self cellPositioning: position!
Item was added:
+ ----- Method: SystemProgressMorph>>setDefaultParameters (in category 'initialization') -----
+ setDefaultParameters
+ "change the receiver's appareance parameters"
+
+ | colorFromMenu worldColor menuColor |
+
+ colorFromMenu := Preferences menuColorFromWorld
+ and: [Display depth > 4
+ and: [(worldColor := self currentWorld color) isColor]].
+
+ menuColor := colorFromMenu
+ ifTrue: [worldColor luminance > 0.7
+ ifTrue: [worldColor mixed: 0.85 with: Color black]
+ ifFalse: [worldColor mixed: 0.4 with: Color white]]
+ ifFalse: [Preferences menuColor].
+
+ self color: menuColor.
+
+ MenuMorph roundedMenuCorners
+ ifTrue: [self useRoundedCorners].
+ self borderWidth: Preferences menuBorderWidth.
+
+ Preferences menuAppearance3d ifTrue: [
+ self borderStyle: BorderStyle thinGray.
+ self hasDropShadow: true.
+
+ self useSoftDropShadow
+ ifFalse: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666);
+ shadowOffset: 1 @ 1]
+ ifTrue: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.01);
+ shadowOffset: (10 at 8 corner: 10 at 12) ]
+ ]
+ ifFalse: [
+ | menuBorderColor |
+ menuBorderColor := colorFromMenu
+ ifTrue: [worldColor muchDarker]
+ ifFalse: [Preferences menuBorderColor].
+ self borderColor: menuBorderColor.
+ ].
+
+ self
+ updateColor: self
+ color: self color
+ intensity: 1.!
Item was added:
+ ----- Method: SystemProgressMorph>>setLabel:at: (in category 'labelling') -----
+ setLabel: shortDescription at: slot
+ (labels at: slot) contents: shortDescription.
+ self reposition!
Item was added:
+ ----- Method: SystemProgressMorph>>slideToTrash: (in category 'dropping/grabbing') -----
+ slideToTrash: evt
+ "If the user needs to dismiss a progress morph by hand, start with a
+ fresh instance next time."
+ self dismissViaHalo!
Item was added:
+ ----- Method: SystemProgressMorph>>updateColor:color:intensity: (in category 'initialization') -----
+ updateColor: aMorph color: aColor intensity: anInteger
+ "update the apareance of aMorph"
+ | fill |
+ MenuMorph gradientMenu
+ ifFalse: [^ self].
+
+ fill := GradientFillStyle ramp: {0.0 -> Color white. 1 ->aColor}.
+ fill radial: false;
+ origin: aMorph topLeft;
+ direction: 0 @ aMorph height.
+ aMorph fillStyle: fill!
Item was added:
+ MorphicModel subclass: #SystemWindow
+ instanceVariableNames: 'labelString stripes label closeBox collapseBox activeOnlyOnTop paneMorphs paneRects collapsedFrame fullFrame isCollapsed menuBox mustNotClose labelWidgetAllowance updatablePanes allowReframeHandles labelArea expandBox'
+ classVariableNames: 'ClickOnLabelToEdit CloseBoxFrame CloseBoxImageFlat CloseBoxImageGradient CollapseBoxImageFlat CollapseBoxImageGradient DoubleClickOnLabelToExpand ExpandBoxFrame ExpandBoxImageFlat ExpandBoxImageGradient GradientWindow HideExpandButton MenuBoxFrame MenuBoxImageFlat MenuBoxImageGradient ResizeAlongEdges ReuseWindows TopWindow'
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !SystemWindow commentStamp: '<historical>' prior: 0!
+ SystemWindow is the Morphic equivalent of StandardSystemView -- a labelled container for rectangular views, with iconic facilities for close, collapse/expand, and resizing.
+
+ The attribute onlyActiveOnTop, if set to true (and any call to activate will set this), determines that only the top member of a collection of such windows on the screen shall be active. To be not active means that a mouse click in any region will only result in bringing the window to the top and then making it active.!
Item was added:
+ ----- Method: SystemWindow class>>borderWidth (in category 'initializing') -----
+ borderWidth
+
+ "Making changes to this for some reason requires repositioning of CornerGripMorphs.
+ Edit BorderedMorph#addCornerGrip and play with offsets to get them right if you increase
+ border width. For instance, going from 4 to 6 here and you should updated offsets to
+ (-23 at -23 corner: 0 at 0) for the right placement of corner grips."
+
+ ^ 4!
Item was added:
+ ----- Method: SystemWindow class>>boxExtent (in category 'preferences') -----
+ boxExtent
+ "answer the extent to use in all the buttons"
+
+ ^ (Preferences alternativeWindowBoxesLook
+ ifTrue: [18 @ 18]
+ ifFalse: [16 @ 16])!
Item was added:
+ ----- Method: SystemWindow class>>classVersion (in category 'initializing') -----
+ classVersion
+ "Changed to 1 for SystemWindow Dec 2000 - see if this helps loading old ones"
+ ^ 1!
Item was added:
+ ----- Method: SystemWindow class>>clearTopWindow (in category 'top window') -----
+ clearTopWindow
+
+ TopWindow := nil. "if leaving morphic to export from mvc, this ref could cause problems"!
Item was added:
+ ----- Method: SystemWindow class>>clickOnLabelToEdit (in category 'preferences') -----
+ clickOnLabelToEdit
+
+ <preference: 'Click On Label To Edit'
+ category: 'windows'
+ description: 'If true, a click on the label of a system window lets you edit it'
+ type: #Boolean>
+ ^ ClickOnLabelToEdit ifNil: [false].
+ !
Item was added:
+ ----- Method: SystemWindow class>>clickOnLabelToEdit: (in category 'preferences') -----
+ clickOnLabelToEdit: aBoolean
+
+ ClickOnLabelToEdit := aBoolean.
+ self rebuildAllWindowLabels.!
Item was added:
+ ----- Method: SystemWindow class>>closeBoxFrame (in category 'preferences') -----
+ closeBoxFrame
+
+ ^ CloseBoxFrame ifNil: [
+ CloseBoxFrame := (LayoutFrame new
+ leftFraction: 0;
+ leftOffset: 2;
+ topFraction: 0;
+ topOffset: 0;
+ yourself)]!
Item was added:
+ ----- Method: SystemWindow class>>closeBoxImage (in category 'initializing') -----
+ closeBoxImage
+
+ ^ self gradientWindow
+ ifTrue: [self closeBoxImageGradient]
+ ifFalse: [self closeBoxImageFlat].
+ !
Item was added:
+ ----- Method: SystemWindow class>>closeBoxImageFlat (in category 'initializing') -----
+ closeBoxImageFlat
+
+ ^ CloseBoxImageFlat ifNil: [CloseBoxImageFlat := (Form
+ extent: 12 at 12
+ depth: 32
+ fromArray: #( 0 0 552294233 2683000665 4025177945 4293613401 4293613401 4025177945 2683000665 552294233 0 0 0 1089165145 4025177945 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4025177945 820729689 0 552294233 4025177945 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4025177945 283858777 2683000665 4293613401 4293613401 4294492353 4294492353 4293613401 4293613401 4294492353 4294492353 4293613401 4293613401 2683000665 4025177945 4293613401 4293613401 4294492353 4294967295 4294492353 4294492353 4294967295 4294492353 4293613401 4293613401 4025177945 4293613401 4293613401 4293613401 4293613401 4294492353 4294967295 4294967295 4294492353 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4294492353 4294967295 4294967295 4294492353 4293613401 4293613401 4293613401 4293613401 4025177945 4293613401 4293613401 4294492353 4294967295 4294492353 4294492353 4294967295 4294492353 4293613401 4293613401 3756742489 2683000665 4293613401 4293613401 4294492353 4294492353 4293613401 4293613401 4294492353 4294492353 4293613401 4293613401 2162906969 552294233 4025177945 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4025177945 283858777 0 820729689 4025177945 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4025177945 820729689 0 0 0 283858777 2683000665 4025177945 4293613401 4293613401 3756742489 2162906969 283858777 0 0)
+ offset: 0 at 0)]!
Item was added:
+ ----- Method: SystemWindow class>>closeBoxImageGradient (in category 'initializing') -----
+ closeBoxImageGradient
+
+ ^ CloseBoxImageGradient ifNil: [CloseBoxImageGradient := (Form
+ extent: 14 at 14
+ depth: 32
+ fromArray: #(0 0 6032910 288687365 1550655006 2844865845 3450028610 3450028610 2828088372 1550655006 288687365 5967374 0 0 1377027 15091784 844830230 3063889984 4158092147 4294153621 4294681250 4294681250 4294153364 4158091376 3047046718 844764694 14763847 1376770 7742243 861541910 3585164870 4294282123 4294943908 4294943908 4294943651 4294943651 4294943908 4294943908 4294216330 3585099848 844764694 7676450 288098055 3047109684 4294211447 4294939539 4293757578 4293363848 4294939025 4294939282 4293954186 4293560456 4294939539 4294212732 3047110455 288031748 1584209695 4158081610 4294932343 4293753466 4291733929 4291802549 4293164156 4293884281 4291666594 4291670192 4293294457 4294933885 4158018130 1567432222 2861706541 4294136145 4294924376 4292761945 4292198592 4294704894 4292064950 4291403679 4294375158 4293057499 4291846497 4294925147 4294136659 2844863789 3483644980 4294660947 4294923605 4294857555 4292566879 4292658886 4294770173 4294704380 4293452000 4291981681 4294595154 4294923605 4294660947 3466867764 3500422196 4294726483 4294923605 4294923605 4293742415 4291402908 4294836223 4294967295 4292198592 4292760660 4294923348 4294923605 4294660947 3483644980 2878484014 4294136145 4294923605 4293939794 4291728018 4294375158 4293452257 4292793042 4294704637 4292128944 4293154390 4294923605 4294136145 2878484014 1617830177 4174923591 4294923862 4292957011 4292000442 4293386721 4291915888 4292238685 4292659400 4292595406 4292303450 4294923605 4158146375 1617829920 305072650 3097572147 4294267217 4294923348 4292631901 4291781989 4294595154 4294857555 4292435036 4292238942 4294857812 4294267217 3097506611 305007114 8070437 912005658 3635624249 4294333010 4294923605 4294857555 4294923605 4294923605 4294923348 4294923348 4294333010 3635624249 895228442 8004901 1639428 16735838 912071451 3131126579 4191766343 4294267217 4294726740 4294726740 4294201681 4191766343 3131126579 895293978 16735067 1573892 0 0 6888733 322506254 1651515681 2945723950 3550885173 3550885173 2945723950 1651515681 322440718 6822940 0 0)
+ offset: 0 at 0)]!
Item was added:
+ ----- Method: SystemWindow class>>closeTopWindow (in category 'top window') -----
+ closeTopWindow
+ "Try to close the top window. It may of course decline"
+
+ TopWindow ifNotNil:
+ [TopWindow delete]!
Item was added:
+ ----- Method: SystemWindow class>>collapseBoxImage (in category 'initializing') -----
+ collapseBoxImage
+
+ ^ self gradientWindow
+ ifTrue: [self collapseBoxImageGradient]
+ ifFalse: [self collapseBoxImageFlat].
+ !
Item was added:
+ ----- Method: SystemWindow class>>collapseBoxImageFlat (in category 'initializing') -----
+ collapseBoxImageFlat
+
+ ^ CollapseBoxImageFlat ifNil: [CollapseBoxImageFlat := (Form
+ extent: 12 at 12
+ depth: 32
+ fromArray: #( 0 0 552699410 2683405842 4025583122 4294018578 4294018578 4025583122 2683405842 552699410 0 0 0 1089570322 4025583122 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4025583122 821134866 0 552699410 4025583122 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4025583122 284263954 2683405842 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 2683405842 4025583122 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4025583122 4294018578 4294221118 4294762948 4294762948 4294762948 4294762948 4294762948 4294762948 4294762948 4294762948 4294221118 4294018578 4294018578 4294221118 4294762948 4294762948 4294762948 4294762948 4294762948 4294762948 4294762948 4294762948 4294221118 4294018578 4025583122 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 3757147666 2683405842 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 2163312146 552699410 4025583122 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4025583122 284263954 0 821134866 4025583122 4294018578 4294018578 4294018578 4294018578 4294018578 4294018578 4025583122 821134866 0 0 0 284263954 2683405842 4025583122 4294018578 4294018578 3757147666 2163312146 284263954 0 0)
+ offset: 0 at 0)]!
Item was added:
+ ----- Method: SystemWindow class>>collapseBoxImageGradient (in category 'initializing') -----
+ collapseBoxImageGradient
+
+ ^ CollapseBoxImageGradient ifNil: [CollapseBoxImageGradient := (Form
+ extent: 14 at 14
+ depth: 32
+ fromArray: #(0 768 5853184 288569344 1550537988 2844748052 3449976096 3449976096 2827970835 1550537731 288569600 5787392 768 0 1256960 15043082 844713216 3063837470 4158037328 4294162549 4294689156 4294689156 4294162292 4158036813 3046994460 844713216 14714890 1256704 7690756 861424896 3585112609 4294226279 4294952069 4294952069 4294951812 4294951812 4294952069 4294952068 4294226278 3585047331 844647680 7625220 287914752 3047058190 4294222924 4294949230 4294948716 4294948716 4294948716 4294948716 4294948716 4294948717 4294949231 4294223955 3047058707 287914240 1584092675 4158030361 4294944327 4294945619 4294945877 4294946134 4294946134 4294945877 4294945619 4294945102 4294944587 4294945360 4158031652 1567315202 2861589770 4294150937 4294938911 4294217252 4293955628 4294021937 4294021938 4294021421 4294020390 4293954079 4294084893 4294873892 4294151196 2844812298 3483593741 4294741530 4294478360 4291271017 4292461743 4292461485 4292461485 4292461485 4292461485 4292527535 4291340680 4293625630 4294807066 3466816525 3500370957 4294741530 4294347032 4291669904 4294112759 4294112244 4294112244 4294112244 4294112244 4294243831 4292200893 4293428769 4294807066 3483593741 2878432779 4294150937 4294806810 4292511536 4292382532 4292382531 4292382531 4292382531 4292382531 4292382532 4292249912 4294347548 4294216473 2878432523 1617712902 4174872597 4294938651 4294938393 4294938136 4294938136 4294938136 4294938136 4294938136 4294938136 4294938393 4294938651 4158095381 1617712902 304955136 3097520909 4294282265 4294938395 4294938395 4294938395 4294938395 4294938395 4294938395 4294938395 4294938395 4294282009 3097455373 304889600 7953671 911888388 3635573264 4294347801 4294938651 4294938395 4294938395 4294938395 4294938395 4294938651 4294347801 3635573264 895111172 7888135 1520128 16753431 911954180 3131075341 4191781141 4294216473 4294741530 4294741530 4294216473 4191781141 3131075341 895176964 16752406 1454592 0 3072 6708483 322388481 1651398919 2945607436 3550833934 3550833934 2945607436 1651398919 322322945 6642947 2816 0)
+ offset: 0 at 0)]!
Item was added:
+ ----- Method: SystemWindow class>>doubleClickOnLabelToExpand (in category 'preferences') -----
+ doubleClickOnLabelToExpand
+
+ <preference: 'Double-Click On Label To Expand'
+ category: 'windows'
+ description: 'Activates expansion through double-clicking on the window label area. This mimics the behavior in many current operating systems'
+ type: #Boolean>
+ ^ DoubleClickOnLabelToExpand ifNil: [true].
+ !
Item was added:
+ ----- Method: SystemWindow class>>doubleClickOnLabelToExpand: (in category 'preferences') -----
+ doubleClickOnLabelToExpand: aBoolean
+
+ DoubleClickOnLabelToExpand := aBoolean.
+ self rebuildAllWindowLabels.
+ !
Item was added:
+ ----- Method: SystemWindow class>>expandBoxFrame (in category 'preferences') -----
+ expandBoxFrame
+
+ ^ ExpandBoxFrame ifNil: [
+ ExpandBoxFrame := (LayoutFrame new
+ leftFraction: 1;
+ leftOffset: (self boxExtent x * 2 + 3) negated;
+ topFraction: 0;
+ topOffset: 0;
+ yourself)]!
Item was added:
+ ----- Method: SystemWindow class>>expandBoxImage (in category 'initializing') -----
+ expandBoxImage
+
+ ^ self gradientWindow
+ ifTrue: [self expandBoxImageGradient]
+ ifFalse: [self expandBoxImageFlat].
+ !
Item was added:
+ ----- Method: SystemWindow class>>expandBoxImageFlat (in category 'initializing') -----
+ expandBoxImageFlat
+
+ ^ ExpandBoxImageFlat ifNil: [ExpandBoxImageFlat := (Form
+ extent: 12 at 12
+ depth: 32
+ fromArray: #( 0 0 542547506 2673253938 4015431218 4283866674 4283866674 4015431218 2673253938 542547506 0 0 0 1079418418 4015431218 4283866674 4283866674 4285968472 4285968472 4283866674 4283866674 4015431218 810982962 0 542547506 4015431218 4283866674 4283866674 4283866674 4292208588 4292208588 4283866674 4283866674 4283866674 4015431218 274112050 2673253938 4283866674 4283866674 4283866674 4283866674 4292208588 4292208588 4283866674 4283866674 4283866674 4283866674 2673253938 4015431218 4283866674 4283866674 4283866674 4283866674 4292208588 4292208588 4283866674 4283866674 4283866674 4283866674 4015431218 4283866674 4285968472 4292208588 4292208588 4292208588 4294244850 4294244850 4292208588 4292208588 4292208588 4285968472 4283866674 4283866674 4285968472 4292208588 4292208588 4292208588 4294244850 4294244850 4292208588 4292208588 4292208588 4285968472 4283866674 4015431218 4283866674 4283866674 4283866674 4283866674 4292208588 4292208588 4283866674 4283866674 4283866674 4283866674 3746995762 2673253938 4283866674 4283866674 4283866674 4283866674 4292208588 4292208588 4283866674 4283866674 4283866674 4283866674 2153160242 542547506 4015431218 4283866674 4283866674 4283866674 4292208588 4292208588 4283866674 4283866674 4283866674 4015431218 274112050 0 810982962 4015431218 4283866674 4283866674 4285968472 4285968472 4283866674 4283866674 4015431218 810982962 0 0 0 274112050 2673253938 4015431218 4283866674 4283866674 3746995762 2153160242 274112050 0 0)
+ offset: 0 at 0)]!
Item was added:
+ ----- Method: SystemWindow class>>expandBoxImageGradient (in category 'initializing') -----
+ expandBoxImageGradient
+
+ ^ ExpandBoxImageGradient ifNil: [ExpandBoxImageGradient := (Form
+ extent: 14 at 14
+ depth: 32
+ fromArray: #(0 0 1058562 285544960 1545616142 2838976800 3443812652 3443812652 2822199328 1545550349 285610496 1058562 0 0 197889 5015843 840445449 3057804586 4151680347 4288134782 4288989580 4288989580 4288134525 4151549016 3040961576 840379656 4949796 132352 2441745 857222409 3578360366 4287543665 4289187213 4289121422 4288857993 4288792456 4289121421 4289121677 4287478128 3578491696 840445193 2375953 285740802 3040304923 4286295641 4288070777 4288004983 4287543410 4288524177 4289312671 4287344755 4288004983 4288136313 4286624095 3040502048 285543680 1579236111 4149118761 4286297173 4286822495 4286888545 4286426462 4291679432 4293717227 4286752873 4286560090 4286428504 4286691421 4149578546 1562393102 2855294231 4283865130 4284326448 4284325172 4284718907 4284716865 4291416516 4293651691 4285043786 4284061998 4283996461 4284523316 4283996461 2838517015 3476513307 4284063275 4283865386 4287341947 4290759608 4290693559 4293717483 4294572537 4291153599 4290759607 4288129929 4283864876 4283997739 3459736090 3493290523 4284063275 4283799593 4289312927 4294243316 4294046193 4294769916 4294901502 4294177779 4294243316 4290364338 4283864621 4284063275 3476513306 2872071703 4283865130 4284063275 4284453693 4285176395 4285109069 4291811019 4293849070 4285962336 4285110602 4284585024 4283997227 4283799593 2872071447 1612856592 4165698852 4284195372 4284063786 4284064041 4283864620 4291285440 4293651690 4284782402 4283998248 4284063786 4284195372 4148921636 1612856336 302649860 3090571034 4283865642 4284129580 4284129580 4283930157 4289378465 4291218626 4284519486 4284064042 4284129580 4283865642 3090505498 302649604 2573587 907751437 3627904029 4283865642 4284195372 4284063275 4284060978 4284126260 4283996972 4284195372 4283865642 3627838237 890974221 2573330 263937 6533168 907817229 3124125722 4182476324 4283865386 4284063531 4284063531 4283865386 4182476324 3124125722 891040013 6335279 263937 0 0 1979406 319691015 1646476817 2939246103 3543687963 3543687963 2939246103 1646476817 319691015 1979406 0 0)
+ offset: 0 at 0) ]!
Item was added:
+ ----- Method: SystemWindow class>>gradientWindow (in category 'preferences') -----
+ gradientWindow
+
+ <preference: 'gradientWindow'
+ category: 'windows'
+ description: 'If true, windows will have a gradient look.'
+ type: #Boolean>
+ ^ GradientWindow ifNil: [true]
+ !
Item was added:
+ ----- Method: SystemWindow class>>gradientWindow: (in category 'preferences') -----
+ gradientWindow: aBoolean
+
+ aBoolean = GradientWindow ifTrue: [^ self].
+ GradientWindow := aBoolean.
+ self refreshAllWindows.!
Item was added:
+ ----- Method: SystemWindow class>>hideExpandButton (in category 'preferences') -----
+ hideExpandButton
+
+ <preference: 'Hide Expand Button'
+ category: 'windows'
+ description: 'Hides the expand button in all windows'
+ type: #Boolean>
+ ^ HideExpandButton ifNil: [ false ]
+ !
Item was added:
+ ----- Method: SystemWindow class>>hideExpandButton: (in category 'preferences') -----
+ hideExpandButton: aBoolean
+
+ HideExpandButton := aBoolean.
+ "Have the menu button frame rebuilt accordingly"
+ self moveMenuButtonRight: self moveMenuButtonRight.
+ !
Item was added:
+ ----- Method: SystemWindow class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ "Include my subclasses but not me"
+ ^ self ~~ SystemWindow!
Item was added:
+ ----- Method: SystemWindow class>>initialize (in category 'initializing') -----
+ initialize
+ "SystemWindow initialize"
+
+ CollapseBoxImageGradient := nil.
+ CloseBoxImageGradient := nil.
+ ExpandBoxImageGradient := nil.
+ MenuBoxImageGradient := nil.
+
+ CollapseBoxImageFlat := nil.
+ CloseBoxImageFlat := nil.
+ ExpandBoxImageFlat := nil.
+ MenuBoxImageFlat := nil.
+
+ self updatePreferences.!
Item was added:
+ ----- Method: SystemWindow class>>labelled: (in category 'instance creation') -----
+ labelled: labelString
+
+ ^ self basicNew
+ initializeWithLabel: labelString;
+ yourself!
Item was added:
+ ----- Method: SystemWindow class>>menuBoxFrame (in category 'preferences') -----
+ menuBoxFrame
+
+ ^ MenuBoxFrame ifNil: [
+ MenuBoxFrame := (LayoutFrame new
+ leftFraction: 0;
+ leftOffset: self boxExtent x + 3;
+ topFraction: 0;
+ topOffset: 0;
+ yourself)]!
Item was added:
+ ----- Method: SystemWindow class>>menuBoxImage (in category 'initializing') -----
+ menuBoxImage
+
+ ^ self gradientWindow
+ ifTrue: [self menuBoxImageGradient]
+ ifFalse: [self menuBoxImageFlat].
+ !
Item was added:
+ ----- Method: SystemWindow class>>menuBoxImageFlat (in category 'initializing') -----
+ menuBoxImageFlat
+
+ ^ MenuBoxImageFlat ifNil: [MenuBoxImageFlat := (Form
+ extent: 12 at 12
+ depth: 32
+ fromArray: #( 0 0 540831669 2671538101 4013715381 4282150837 4282150837 4013715381 2671538101 540831669 0 0 0 1077702581 4013715381 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4013715381 809267125 0 540831669 4013715381 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4013715381 272396213 2671538101 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 2671538101 4013715381 4282150837 4284582595 4288591834 4288591834 4288591834 4288591834 4288591834 4288591834 4283728318 4282150837 4013715381 4282150837 4282150837 4282939578 4292535537 4294967295 4294967295 4294967295 4294967295 4292535537 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4284582595 4294967295 4294967295 4294967295 4294178554 4283728318 4282150837 4282150837 4282150837 4013715381 4282150837 4282150837 4282150837 4287737557 4294967295 4294967295 4286948817 4282150837 4282150837 4282150837 3745279925 2671538101 4282150837 4282150837 4282150837 4282150837 4291746797 4290958056 4282150837 4282150837 4282150837 4282150837 2151444405 540831669 4013715381 4282150837 4282150837 4282150837 4282939578 4282939578 4282150837 4282150837 4282150837 4013715381 272396213 0 809267125 4013715381 4282150837 4282150837 4282150837 4282150837 4282150837 4282150837 4013715381 809267125 0 0 0 272396213 2671538101 4013715381 4282150837 4282150837 3745279925 2151444405 272396213 0 0)
+ offset: 0 at 0)]!
Item was added:
+ ----- Method: SystemWindow class>>menuBoxImageGradient (in category 'initializing') -----
+ menuBoxImageGradient
+
+ ^ MenuBoxImageGradient ifNil: [MenuBoxImageGradient := (Form
+ extent: 14 at 14
+ depth: 32
+ fromArray: #(0 0 7774 285216318 1544039783 2837267842 3442168720 3442168720 2820490625 1544039782 285216574 7774 0 0 2087 1532860 839001178 3056161165 4150166716 4286817494 4287738079 4287803615 4286751958 4150035131 3039252364 839001178 1467065 1831 668526 855712858 3576584601 4286029012 4287935459 4287935458 4287869666 4287869666 4287935458 4287869923 4285963476 3576715929 838935642 602733 285216827 3038463881 4284517582 4286621149 4286489564 4286489564 4286489564 4286489564 4286489564 4286489820 4286621149 4284911823 3038726794 285216058 1577594471 4147012271 4284387029 4284978391 4285043927 4285109719 4285109719 4285044183 4284978135 4284649685 4284518357 4284912599 4147603633 1560751463 2853453696 4281560257 4281888189 4283200687 4284186808 4284515256 4284515257 4284252600 4283858102 4283529653 4282740653 4282151359 4281757378 2836676480 3474606220 4281757894 4281559740 4285761703 4292993507 4293454315 4293388522 4293388522 4293454315 4292862177 4285432998 4281494205 4281692102 3457829004 3491383436 4281757638 4281758153 4281953722 4288589251 4294835708 4294967295 4294967295 4294769659 4288194752 4281887931 4281823689 4281692102 3474606220 2870296704 4281560257 4281823689 4281758153 4282215861 4289838026 4294967294 4294967038 4289377991 4282084534 4281758153 4281823689 4281560257 2870296704 1611280232 4163592111 4281823946 4281823688 4281692360 4282740914 4291152852 4290758353 4282544051 4281692361 4281823688 4281823946 4146749358 1611214696 301994814 3088664202 4281626050 4281823689 4281823688 4281692103 4282937773 4282806447 4281692360 4281823688 4281823689 4281626050 3088664202 301994814 734577 906307420 3625930390 4281626050 4281823946 4281823689 4281692360 4281692360 4281823689 4281823946 4281626050 3625930390 889530204 734576 2347 2392036 906373213 3122218634 4180369583 4281560257 4281757638 4281757638 4281560257 4180369583 3122218634 889595997 2325471 2346 0 3 76907 318773060 1644834921 2937405569 3541780621 3541780621 2937405569 1644834921 318773059 76906 2 0)
+ offset: 0 at 0)]!
Item was added:
+ ----- Method: SystemWindow class>>moveMenuButtonRight (in category 'preferences') -----
+ moveMenuButtonRight
+
+ <preference: 'Move Menu Button Right'
+ category: 'windows'
+ description: 'Moves the menu to the right side of the window label area, while traditionally it used to be on the left side'
+ type: #Boolean>
+ ^ self menuBoxFrame leftOffset negative
+ !
Item was added:
+ ----- Method: SystemWindow class>>moveMenuButtonRight: (in category 'preferences') -----
+ moveMenuButtonRight: aBoolean
+
+ | absLeftOffset |
+ absLeftOffset := ((self hideExpandButton and: [aBoolean])
+ ifTrue: [absLeftOffset := self boxExtent x * 2]
+ ifFalse: [absLeftOffset := self boxExtent x]) + 3.
+ self menuBoxFrame leftOffset: (aBoolean
+ ifTrue: [absLeftOffset negated]
+ ifFalse: [absLeftOffset]).
+ self rebuildAllWindowLabels.!
Item was added:
+ ----- Method: SystemWindow class>>noteTopWindowIn: (in category 'top window') -----
+ noteTopWindowIn: aWorld
+ | newTop |
+ "TopWindow must be nil or point to the top window in this project."
+ TopWindow := nil.
+ aWorld ifNil: [^ self].
+ newTop := nil.
+ aWorld submorphsDo:
+ [:m | (m isSystemWindow) ifTrue:
+ [(newTop == nil and: [m activeOnlyOnTop])
+ ifTrue: [newTop := m].
+ (m model isKindOf: Project)
+ ifTrue: ["This really belongs in a special ProjWindow class"
+ m label ~= m model name ifTrue: [m setLabel: m model name]]]].
+ newTop == nil ifFalse: [newTop activate]!
Item was added:
+ ----- Method: SystemWindow class>>rebuildAllWindowLabels (in category 'preferences') -----
+ rebuildAllWindowLabels
+
+ self withAllSubclasses do: [:c | c allInstances do: [:w | w replaceBoxes]].!
Item was added:
+ ----- Method: SystemWindow class>>refreshAllWindows (in category 'initializing') -----
+ refreshAllWindows
+ "If there is some prominent UI change, use this method to update all open windows."
+
+ SystemWindow allSubInstances do: [:w |
+ w
+ setDefaultParameters;
+ refreshWindowColor].!
Item was added:
+ ----- Method: SystemWindow class>>resizeAlongEdges (in category 'preferences') -----
+ resizeAlongEdges
+ <preference: 'Resize Windows along edges'
+ category: 'Morphic'
+ description: 'When true, windows can be resized along their edges as well as the corners'
+ type: #Boolean>
+ ^ResizeAlongEdges ifNil:[true]!
Item was added:
+ ----- Method: SystemWindow class>>resizeAlongEdges: (in category 'preferences') -----
+ resizeAlongEdges: aBool
+ "Preference setter"
+ ResizeAlongEdges := aBool!
Item was added:
+ ----- Method: SystemWindow class>>reuseWindows (in category 'preferences') -----
+ reuseWindows
+
+ <preference: 'Reuse Windows'
+ category: 'browsing'
+ description: 'When enabled, before opening a new window check if there is any open window like it, and if there is, reuse it.'
+ type: #Boolean>
+ ^ReuseWindows ifNil: [ false ]
+ !
Item was added:
+ ----- Method: SystemWindow class>>reuseWindows: (in category 'preferences') -----
+ reuseWindows: aBoolean
+
+ ReuseWindows := aBoolean!
Item was added:
+ ----- Method: SystemWindow class>>sendTopWindowToBack (in category 'top window') -----
+ sendTopWindowToBack
+ "Send the top window of the world to the back, activating the one just beneath it"
+
+ TopWindow ifNotNil:
+ [TopWindow sendToBack]!
Item was added:
+ ----- Method: SystemWindow class>>updatePreferences (in category 'initializing') -----
+ updatePreferences
+ "Temporary method to update system-wide preferences"
+ Preferences installNormalWindowColors.
+
+ Preferences setPreference: #menuAppearance3d toValue: true.
+ (Preferences preferenceAt: #menuAppearance3d) defaultValue: true.
+
+ Preferences setPreference: #menuColorFromWorld toValue: false.
+ (Preferences preferenceAt: #menuColorFromWorld) defaultValue: false.
+
+ MenuMorph roundedMenuCorners: false.
+
+ Preferences setParameter: #menuColor to: (Color gray: 0.9).
+ Preferences setParameter: #menuTitleColor to: (Color transparent).
+ Preferences setParameter: #menuTitleBorderWidth to: 0.
+ Preferences setParameter: #defaultWorldColor to: (Color gray: 0.25).
+
+ Preferences setPreference: #showSplitterHandles toValue: false.
+ (Preferences preferenceAt: #showSplitterHandles) defaultValue: true.
+
+ Preferences setPreference: #showSharedFlaps toValue: false.
+ (Preferences preferenceAt: #showSharedFlaps) defaultValue: false.
+
+ CornerGripMorph drawCornerResizeHandles: false.
+ FillInTheBlankMorph roundedDialogCorners: true.
+
+ LazyListMorph
+ listSelectionColor: LazyListMorph listSelectionColor;
+ listSelectionTextColor: Color black.
+ PluggableButtonMorph roundedButtonCorners: true.
+ SystemWindow
+ clickOnLabelToEdit: false;
+ doubleClickOnLabelToExpand: true;
+ moveMenuButtonRight: true;
+ hideExpandButton: false.!
Item was added:
+ ----- Method: SystemWindow class>>wakeUpTopWindowUponStartup (in category 'top window') -----
+ wakeUpTopWindowUponStartup
+ TopWindow ifNotNil:
+ [TopWindow isCollapsed ifFalse:
+ [TopWindow model ifNotNil:
+ [TopWindow model modelWakeUpIn: TopWindow]]]!
Item was added:
+ ----- Method: SystemWindow class>>windowsIn:satisfying: (in category 'top window') -----
+ windowsIn: aWorld satisfying: windowBlock
+ | windows |
+
+ windows := OrderedCollection new.
+ aWorld ifNil: [^windows]. "opening MVC in Morphic - WOW!!"
+ aWorld submorphs do:
+ [:m | | s |
+ ((m isSystemWindow) and: [windowBlock value: m])
+ ifTrue: [windows addLast: m]
+ ifFalse: [((m isKindOf: TransformationMorph) and: [m submorphs size = 1])
+ ifTrue: [s := m firstSubmorph.
+ ((s isSystemWindow) and: [windowBlock value: s])
+ ifTrue: [windows addLast: s]]]].
+ ^ windows!
Item was added:
+ ----- Method: SystemWindow>>activate (in category 'top window') -----
+ activate
+ "Activate the owner too."
+
+ |mo mc|
+ mo := self modalOwner.
+ mc := self modalChild.
+ mc isNil
+ ifFalse: [mc owner notNil ifTrue: [
+ mc activate.
+ ^mc modalChild isNil ifTrue: [mc flash]]].
+ (isCollapsed not and: [
+ self paneMorphs size > 1 and: [
+ self splitters isEmpty ] ]) ifTrue: [ self addPaneSplitters ].
+ self activateWindow.
+ self rememberedKeyboardFocus
+ ifNil: [(self respondsTo: #navigateFocusForward)
+ ifTrue: [self navigateFocusForward]]
+ ifNotNil: [:m | m world
+ ifNil: [self rememberKeyboardFocus: nil] "deleted"
+ ifNotNil: [:w |
+ m wantsKeyboardFocus
+ ifTrue: [m takeKeyboardFocus]
+ ifFalse: [(self respondsTo: #navigateFocusForward)
+ ifTrue: [self navigateFocusForward]]]].
+ (mo notNil and: [mo isKindOf: SystemWindow])
+ ifTrue: [mo bringBehind: self]!
Item was added:
+ ----- Method: SystemWindow>>activateAndForceLabelToShow (in category 'top window') -----
+ activateAndForceLabelToShow
+ self activate.
+ bounds top < 0 ifTrue:
+ [self position: (self position x @ 0)]!
Item was added:
+ ----- Method: SystemWindow>>activateWindow (in category 'top window') -----
+ activateWindow
+ "Bring me to the front and make me able to respond to mouse and keyboard.
+ Was #activate (sw 5/18/2001 23:20)"
+
+ | oldTop outerMorph sketchEditor pal |
+ self hasDropShadow: Preferences menuAppearance3d.
+
+ outerMorph := self topRendererOrSelf.
+ outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"].
+ oldTop := TopWindow.
+ oldTop = self ifTrue: [^self].
+ TopWindow := self.
+ oldTop ifNotNil: [oldTop passivate].
+ outerMorph owner firstSubmorph == outerMorph
+ ifFalse: ["Bring me (with any flex) to the top if not already"
+ outerMorph owner addMorphFront: outerMorph].
+ self submorphsDo: [:m | m unlock].
+
+ label ifNotNil: [label color: Color black].
+
+ self undimWindowButtons.
+ labelArea ifNotNil: [labelArea submorphsDo: [:m | m unlock; show]].
+ self
+ setStripeColorsFrom: self paneColorToUse;
+ adoptPaneColor: self paneColorToUse.
+
+ self isCollapsed ifFalse:
+ [model modelWakeUpIn: self.
+ self positionSubmorphs.
+ labelArea ifNil: [self adjustBorderUponActivationWhenLabeless]].
+
+ (sketchEditor := self extantSketchEditor) ifNotNil:
+ [sketchEditor comeToFront.
+ (pal := self world findA: PaintBoxMorph) ifNotNil:
+ [pal comeToFront]].
+
+ self updatePaneColors.!
Item was added:
+ ----- Method: SystemWindow>>activeOnlyOnTop (in category 'top window') -----
+ activeOnlyOnTop
+ ^ activeOnlyOnTop ifNil: [false]!
Item was added:
+ ----- Method: SystemWindow>>activeOnlyOnTop: (in category 'top window') -----
+ activeOnlyOnTop: trueOrFalse
+ activeOnlyOnTop := trueOrFalse!
Item was added:
+ ----- Method: SystemWindow>>addCloseBox (in category 'initialization') -----
+ addCloseBox
+ "If I have a labelArea, add a close box to it"
+
+ labelArea
+ ifNil: [^ self].
+ closeBox ifNotNil: [closeBox delete].
+ closeBox := self createCloseBox.
+ closeBox layoutFrame: self class closeBoxFrame.
+ labelArea addMorphFront: closeBox!
Item was added:
+ ----- Method: SystemWindow>>addCornerGrips (in category 'initialization') -----
+ addCornerGrips
+ "When enabled via preference, also add edge grips"
+ super addCornerGrips.
+ self class resizeAlongEdges ifTrue:[self addEdgeGrips].!
Item was added:
+ ----- Method: SystemWindow>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ "template..."
+ aCustomMenu addLine.
+ aCustomMenu add: 'edit label...' translated action: #relabel.
+ !
Item was added:
+ ----- Method: SystemWindow>>addExpandBox (in category 'initialization') -----
+ addExpandBox
+ "If I have a labelArea, add a close box to it"
+
+ labelArea ifNil: [^ self].
+ self class hideExpandButton ifTrue: [^ self].
+ expandBox ifNotNil: [expandBox delete].
+ expandBox := self createExpandBox.
+ expandBox layoutFrame: self class expandBoxFrame.
+ labelArea addMorphBack: expandBox!
Item was added:
+ ----- Method: SystemWindow>>addLabel (in category 'label') -----
+ addLabel
+
+ (labelArea isNil or: [label isNil]) ifTrue: [^ self].
+ labelArea
+ addMorphBack: (Morph new extent: self class borderWidth @ 0);
+ addMorphBack: label.
+ label on: #startDrag send: #startDragFromLabel: to: self.
+ self class clickOnLabelToEdit
+ ifTrue: [label on: #mouseUp send: #relabel to: self].
+ self class doubleClickOnLabelToExpand
+ ifTrue: [label on: #doubleClick send: #expandBoxHit to: self].!
Item was added:
+ ----- Method: SystemWindow>>addLabelArea (in category 'initialization') -----
+ addLabelArea
+
+ labelArea ifNotNil: [labelArea abandon].
+ labelArea := (AlignmentMorph newSpacer: Color transparent)
+ vResizing: #spaceFill;
+ layoutPolicy: ProportionalLayout new.
+ self addMorph: labelArea.!
Item was added:
+ ----- Method: SystemWindow>>addMenuControl (in category 'initialization') -----
+ addMenuControl
+ "If I have a label area, add a menu control to it."
+
+ labelArea ifNil: [^ self].
+ "No menu if no label area"
+ menuBox ifNotNil: [menuBox delete].
+ menuBox := self createMenuBox.
+ menuBox layoutFrame: self class menuBoxFrame.
+ labelArea addMorphBack: menuBox!
Item was added:
+ ----- Method: SystemWindow>>addMorph:frame: (in category 'panes') -----
+ addMorph: aMorph frame: relFrame
+ | frame |
+ frame := LayoutFrame new.
+ frame
+ leftFraction: relFrame left;
+ rightFraction: relFrame right;
+ topFraction: relFrame top;
+ bottomFraction: relFrame bottom.
+ self addMorph: aMorph fullFrame: frame.
+
+ !
Item was added:
+ ----- Method: SystemWindow>>addMorph:fullFrame: (in category 'panes') -----
+ addMorph: aMorph fullFrame: aLayoutFrame
+ "Add aMorph according to aLayoutFrame."
+ | windowBorderWidth |
+ windowBorderWidth := self class borderWidth.
+ "If the property #allowPaneSplitters is set to false, do *not* inset morphs by the borderWidth
+ to make room for splitters. This allows windows with non-traditional contents to avoid their
+ component morphs from being clipped. Do *NOT* remove this code please!! Just because
+ there may be no setters of allowPaneSplitters to false in the image doesn't mean they're not
+ out there. Thanks!! eem 6/13/2013"
+ (self valueOfProperty: #allowPaneSplitters ifAbsent: [true]) ifTrue:
+ [| left right bottom top |
+
+ left := aLayoutFrame leftOffset ifNil: [0].
+ right := aLayoutFrame rightOffset ifNil: [0].
+
+ bottom := aLayoutFrame bottomOffset ifNil: [0].
+ top := aLayoutFrame topOffset ifNil: [0].
+
+ aLayoutFrame rightFraction = 1 ifTrue: [aLayoutFrame rightOffset: right - windowBorderWidth].
+ aLayoutFrame leftFraction = 0
+ ifTrue: [aLayoutFrame leftOffset: left + windowBorderWidth]
+ ifFalse: [aLayoutFrame leftOffset: left + ProportionalSplitterMorph splitterWidth].
+
+ aLayoutFrame bottomFraction = 1 ifTrue: [aLayoutFrame bottomOffset: bottom - windowBorderWidth].
+ aLayoutFrame topFraction = 0
+ ifTrue: [aLayoutFrame topOffset: top + windowBorderWidth]
+ ifFalse: [aLayoutFrame topOffset: top + ProportionalSplitterMorph splitterWidth]].
+
+ "this code should not be here!!!! As of 6/13/2013 there aren't even any users of BrowserCommentTextMorph."
+ (aMorph class name = #BrowserCommentTextMorph) ifTrue:
+ [aLayoutFrame rightOffset: windowBorderWidth negated.
+ aLayoutFrame leftOffset: windowBorderWidth.
+ aLayoutFrame bottomOffset: windowBorderWidth negated.
+ aLayoutFrame topOffset: (windowBorderWidth negated) + 4].
+
+ super addMorph: aMorph fullFrame: aLayoutFrame.
+
+ paneMorphs := paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph).
+ aMorph isImageMorph ifFalse:
+ [aMorph adoptPaneColor: self paneColor.
+ aMorph borderWidth: 1; borderColor: Color lightGray; color: Color white].
+ Preferences scrollBarsOnRight ifTrue:"reorder panes so flop-out right-side scrollbar is visible"
+ [self addMorphBack: aMorph].
+
+ self addPaneSplitters!
Item was added:
+ ----- Method: SystemWindow>>addPaneHSplitters (in category 'initialization') -----
+ addPaneHSplitters
+
+ | remaining targetY sameY |
+ remaining := paneMorphs copy reject: [:each | each layoutFrame bottomFraction = 1].
+ [remaining notEmpty] whileTrue:
+ [targetY := remaining first layoutFrame bottomFraction.
+ sameY := paneMorphs select: [:each | each layoutFrame bottomFraction = targetY].
+ self addPaneHSplitterBetween: remaining first and: sameY.
+ remaining := remaining copyWithoutAll: sameY]!
Item was added:
+ ----- Method: SystemWindow>>addPaneSplitters (in category 'initialization') -----
+ addPaneSplitters
+
+ self removePaneSplitters.
+ self removeCornerGrips.
+
+ self addCornerGrips.
+ self addPaneVSplitters.
+ self addPaneHSplitters.
+
+ self linkSubmorphsToSplitters!
Item was added:
+ ----- Method: SystemWindow>>addPaneVSplitters (in category 'initialization') -----
+ addPaneVSplitters
+
+ | remaining targetX sameX |
+ remaining := paneMorphs copy reject: [:each | each layoutFrame rightFraction = 1].
+ [remaining notEmpty] whileTrue:
+ [targetX := remaining first layoutFrame rightFraction.
+ sameX := paneMorphs select: [:each | each layoutFrame rightFraction = targetX].
+ self addPaneVSplitterBetween: remaining first and: sameX.
+ remaining := remaining copyWithoutAll: sameX]!
Item was added:
+ ----- Method: SystemWindow>>adjustBorderUponActivationWhenLabeless (in category 'top window') -----
+ adjustBorderUponActivationWhenLabeless
+ "Adjust the border upon, um, activation when, um, labelless"
+
+ | aWidth |
+ (aWidth := self valueOfProperty: #borderWidthWhenActive) ifNotNil:
+ [self acquireBorderWidth: aWidth]!
Item was added:
+ ----- Method: SystemWindow>>adjustBorderUponDeactivationWhenLabeless (in category 'top window') -----
+ adjustBorderUponDeactivationWhenLabeless
+ "Adjust the border upon deactivation when, labelless"
+
+ | aWidth |
+ (aWidth := self valueOfProperty: #borderWidthWhenInactive) ifNotNil:
+ [self acquireBorderWidth: aWidth]!
Item was added:
+ ----- Method: SystemWindow>>adoptPaneColor: (in category 'colors handling') -----
+ adoptPaneColor: aPaneColor
+
+ super adoptPaneColor: (self class gradientWindow
+ ifTrue: [aPaneColor ifNotNil: [:c | c duller]]
+ ifFalse: [aPaneColor]).!
Item was added:
+ ----- Method: SystemWindow>>allowReframeHandles (in category 'resize/collapse') -----
+ allowReframeHandles
+
+ ^ allowReframeHandles!
Item was added:
+ ----- Method: SystemWindow>>allowReframeHandles: (in category 'resize/collapse') -----
+ allowReframeHandles: aBoolean
+
+ allowReframeHandles := aBoolean!
Item was added:
+ ----- Method: SystemWindow>>amendSteppingStatus (in category 'stepping') -----
+ amendSteppingStatus
+ "Circumstances having changed, find out whether stepping is wanted and assure that the new policy is carried out"
+
+ self wantsSteps
+ ifTrue:
+ [self arrangeToStartStepping]
+ ifFalse:
+ [self stopStepping]!
Item was added:
+ ----- Method: SystemWindow>>anyOpenWindowLikeMe (in category 'open/close') -----
+ anyOpenWindowLikeMe
+
+ self class reuseWindows ifFalse: [ ^Array empty ].
+ ^ SystemWindow
+ windowsIn: World
+ satisfying:
+ [ : each |
+ each model class = self model class
+ and: [ (each model respondsTo: #representsSameBrowseeAs:)
+ and: [ each model representsSameBrowseeAs: self model ] ] ]
+ !
Item was added:
+ ----- Method: SystemWindow>>applyModelExtent (in category 'initialization') -----
+ applyModelExtent
+ | initialExtent |
+ initialExtent := Preferences bigDisplay
+ ifTrue: [(model initialExtent * 1.5) rounded]
+ ifFalse: [model initialExtent].
+ self extent: initialExtent !
Item was added:
+ ----- Method: SystemWindow>>areasRemainingToFill: (in category 'drawing') -----
+ areasRemainingToFill: aRectangle
+ | areas |
+ (areas := super areasRemainingToFill: aRectangle) isEmpty
+ ifTrue: [^ areas "good news -- complete occlusion"].
+ "Check for special case that this is scrollbar damage"
+ ((bounds topLeft - (14 at 0) corner: bounds bottomRight) containsRect: aRectangle) ifTrue:
+ [paneMorphs do: [:p | ((p isKindOf: ScrollPane) and: [p scrollBarFills: aRectangle])
+ ifTrue: [^ Array new]]].
+ ^ areas!
Item was added:
+ ----- Method: SystemWindow>>boxExtent (in category 'initialization') -----
+ boxExtent
+ "the label height is used to be proportional to the fonts preferences"
+
+ ^ self class boxExtent
+ max: label height @ label height !
Item was added:
+ ----- Method: SystemWindow>>bringBehind: (in category 'polymorph') -----
+ bringBehind: aMorph
+ "Make the receiver be directly behind the given morph.
+ Take into account any modal owner and propagate."
+
+ |outerMorph|
+ outerMorph := self topRendererOrSelf.
+ outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"].
+ outerMorph owner addMorph: outerMorph after: aMorph topRendererOrSelf.
+ self modalOwner ifNotNil: [:mo | mo bringBehind: self]!
Item was added:
+ ----- Method: SystemWindow>>buildWindowMenu (in category 'menu') -----
+ buildWindowMenu
+ | aMenu |
+ aMenu := MenuMorph new defaultTarget: self.
+ aMenu add: 'change title...' translated action: #relabel.
+ aMenu addLine.
+ aMenu add: 'send to back' translated action: #sendToBack.
+ aMenu add: 'make next-to-topmost' translated action: #makeSecondTopmost.
+ aMenu addLine.
+ self mustNotClose
+ ifFalse:
+ [aMenu add: 'make unclosable' translated action: #makeUnclosable]
+ ifTrue:
+ [aMenu add: 'make closable' translated action: #makeClosable].
+ aMenu
+ add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) translated
+ action: #toggleStickiness.
+ aMenu addLine.
+ self unexpandedFrame
+ ifNil: [aMenu add: 'full screen' translated action: #expandBoxHit]
+ ifNotNil: [aMenu add: 'original size' translated action: #expandBoxHit].
+ self isCollapsed ifFalse: [aMenu add: 'window color...' translated action: #setWindowColor].
+ ^aMenu!
Item was added:
+ ----- Method: SystemWindow>>changeColor (in category 'menu') -----
+ changeColor
+ "Change the color of the receiver -- triggered, e.g. from a menu. This variant allows the recolor triggered from the window's halo recolor handle to have the same result as choosing change-window-color from the window-title menu"
+ NewColorPickerMorph useIt
+ ifTrue:
+ [ (NewColorPickerMorph
+ on: self
+ originalColor: self color
+ setColorSelector: #setWindowColor:) openNear: self fullBoundsInWorld ]
+ ifFalse:
+ [ ColorPickerMorph new
+ choseModalityFromPreference ;
+ sourceHand: self activeHand ;
+ target: self ;
+ selector: #setWindowColor: ;
+ originalColor: self color ;
+
+ putUpFor: self
+ near: self fullBoundsInWorld ]!
Item was added:
+ ----- Method: SystemWindow>>closeBoxHit (in category 'open/close') -----
+ closeBoxHit
+ "The user clicked on the close-box control in the window title. For Mac users only, the Mac convention of option-click-on-close-box is obeyed if the mac option key is down."
+
+ Preferences dismissAllOnOptionClose ifTrue:
+ [Sensor rawMacOptionKeyPressed ifTrue:
+ [^ self world closeUnchangedWindows]].
+ self delete
+ !
Item was added:
+ ----- Method: SystemWindow>>collapse (in category 'resize/collapse') -----
+ collapse
+ self isCollapsed ifFalse:[self collapseOrExpand]!
Item was added:
+ ----- Method: SystemWindow>>collapseOrExpand (in category 'resize/collapse') -----
+ collapseOrExpand
+ "Collapse or expand the window, depending on existing state"
+ | cf |
+ isCollapsed
+ ifTrue:
+ ["Expand -- restore panes to morphics structure"
+ isCollapsed := false.
+ self activate. "Bring to frint first"
+ Preferences collapseWindowsInPlace
+ ifTrue:
+ [fullFrame := fullFrame align: fullFrame topLeft with: self getBoundsWithFlex topLeft]
+ ifFalse:
+ [collapsedFrame := self getBoundsWithFlex].
+ collapseBox ifNotNil: [collapseBox setBalloonText: 'collapse this window' translated].
+ self setBoundsWithFlex: fullFrame.
+ paneMorphs reverseDo:
+ [:m | self addMorph: m unlock.
+ self world startSteppingSubmorphsOf: m].
+ self addPaneSplitters]
+ ifFalse:
+ ["Collapse -- remove panes from morphics structure"
+ isCollapsed := true.
+ fullFrame := self getBoundsWithFlex.
+ "First save latest fullFrame"
+ paneMorphs do: [:m | m delete; releaseCachedState].
+ self removePaneSplitters.
+ self removeCornerGrips.
+ model modelSleep.
+ cf := self getCollapsedFrame.
+ (collapsedFrame isNil and: [Preferences collapseWindowsInPlace not]) ifTrue:
+ [collapsedFrame := cf].
+ self setBoundsWithFlex: cf.
+ collapseBox ifNotNil: [collapseBox setBalloonText: 'expand this window' translated ].
+ expandBox ifNotNil: [expandBox setBalloonText: 'expand this window' translated ].
+ self sendToBack].
+ self layoutChanged!
Item was added:
+ ----- Method: SystemWindow>>collapsedFrame (in category 'resize/collapse') -----
+ collapsedFrame
+ ^ collapsedFrame!
Item was added:
+ ----- Method: SystemWindow>>colorForInsets (in category 'drawing') -----
+ colorForInsets
+ ^self paneColor colorForInsets!
Item was added:
+ ----- Method: SystemWindow>>contractToOriginalSize (in category 'resize/collapse') -----
+ contractToOriginalSize
+ self bounds: self unexpandedFrame.
+ self unexpandedFrame: nil.
+ expandBox ifNotNil: [expandBox setBalloonText: 'expand this window' translated].!
Item was added:
+ ----- Method: SystemWindow>>convertAlignment (in category 'layout') -----
+ convertAlignment
+ "Primarily Jesse Welton's code to convert old system windows to ones with modern layout scheme"
+
+ self layoutPolicy: ProportionalLayout new.
+ (paneMorphs isNil
+ or: [paneRects isNil or: [paneMorphs size ~= paneRects size]])
+ ifFalse:
+ [self addLabelArea.
+ self putLabelItemsInLabelArea.
+ self setFramesForLabelArea.
+ paneMorphs with: paneRects
+ do:
+ [:m :r |
+ | frame |
+ frame := LayoutFrame new.
+ frame
+ leftFraction: r left;
+ rightFraction: r right;
+ topFraction: r top;
+ bottomFraction: r bottom.
+ m layoutFrame: frame.
+ m
+ hResizing: #spaceFill;
+ vResizing: #spaceFill]].
+ labelArea isNil
+ ifTrue:
+ [self addLabelArea.
+ self putLabelItemsInLabelArea.
+ self setFramesForLabelArea.
+ paneMorphs ifNotNil:
+ [paneMorphs do:
+ [:m |
+ | frame |
+ frame := m layoutFrame ifNil: [LayoutFrame new].
+ frame topOffset: (frame topOffset ifNil: [0]) - self labelHeight.
+ frame bottomFraction ~= 1.0
+ ifTrue:
+ [frame bottomOffset: (frame bottomOffset ifNil: [0]) - self labelHeight]]]].
+ label ifNotNil:
+ [| frame |
+ frame := LayoutFrame new.
+ frame
+ leftFraction: 0.5;
+ topFraction: 0;
+ leftOffset: label width negated // 2.
+ label layoutFrame: frame].
+ collapseBox ifNotNil:
+ [| frame |
+ frame := LayoutFrame new.
+ frame
+ rightFraction: 1;
+ topFraction: 0;
+ rightOffset: -1;
+ topOffset: 1.
+ collapseBox layoutFrame: frame].
+ stripes ifNotNil:
+ [| frame |
+ frame := LayoutFrame new.
+ frame
+ leftFraction: 0;
+ topFraction: 0;
+ rightFraction: 1;
+ leftOffset: 1;
+ topOffset: 1;
+ rightOffset: -1.
+ stripes first layoutFrame: frame.
+ stripes first height: self labelHeight - 2.
+ stripes first hResizing: #spaceFill.
+ frame := LayoutFrame new.
+ frame
+ leftFraction: 0;
+ topFraction: 0;
+ rightFraction: 1;
+ leftOffset: 3;
+ topOffset: 3;
+ rightOffset: -3.
+ stripes last layoutFrame: frame.
+ stripes last height: self labelHeight - 6.
+ stripes last hResizing: #spaceFill].
+ menuBox ifNotNil:
+ [| frame |
+ frame := LayoutFrame new.
+ frame
+ leftFraction: 0;
+ leftOffset: 19;
+ topFraction: 0;
+ topOffset: 1.
+ menuBox layoutFrame: frame].
+ closeBox ifNotNil:
+ [| frame |
+ frame := LayoutFrame new.
+ frame
+ leftFraction: 0;
+ leftOffset: 4;
+ topFraction: 0;
+ topOffset: 1.
+ closeBox layoutFrame: frame]!
Item was added:
+ ----- Method: SystemWindow>>convertToCurrentVersion:refStream: (in category 'object fileIn') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ allowReframeHandles ifNil: [allowReframeHandles := true].
+ self layoutPolicy ifNil: [self convertAlignment].
+ labelArea ifNil: [self convertAlignment].
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: SystemWindow>>createBox: (in category 'initialization') -----
+ createBox: aForm
+ "create a button with a form to be used in the label area"
+
+ | box |
+ box := SystemWindowButton new.
+ box color: Color transparent;
+ target: self;
+ useSquareCorners;
+ borderWidth: 0;
+ labelGraphic: aForm;
+ extent: self boxExtent.
+ ^ box!
Item was added:
+ ----- Method: SystemWindow>>createCloseBox (in category 'initialization') -----
+ createCloseBox
+ ^ (self createBox: self class closeBoxImage)
+ actionSelector: #closeBoxHit;
+ setBalloonText: 'close this window' translated!
Item was added:
+ ----- Method: SystemWindow>>createCollapseBox (in category 'initialization') -----
+ createCollapseBox
+ ^ (self createBox: self class collapseBoxImage)
+ actionSelector: #collapseOrExpand;
+ setBalloonText: 'collapse this window' translated.
+ !
Item was added:
+ ----- Method: SystemWindow>>createExpandBox (in category 'initialization') -----
+ createExpandBox
+ ^ (self createBox: self class expandBoxImage)
+ actionSelector: #expandBoxHit;
+ setBalloonText: 'expand this window' translated!
Item was added:
+ ----- Method: SystemWindow>>createMenuBox (in category 'initialization') -----
+ createMenuBox
+ ^ (self createBox: self class menuBoxImage)
+ actionSelector: #offerWindowMenu;
+ setBalloonText: 'window menu' translated!
Item was added:
+ ----- Method: SystemWindow>>defaultBorderColor (in category 'initialization') -----
+ defaultBorderColor
+ "answer the default border color/fill style for the receiver"
+ ^ self defaultColor muchDarker!
Item was added:
+ ----- Method: SystemWindow>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 1!
Item was added:
+ ----- Method: SystemWindow>>defaultBounds (in category 'initialization') -----
+ defaultBounds
+
+ ^ 0 at 0 corner: 300 at 200!
Item was added:
+ ----- Method: SystemWindow>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Preferences uniformWindowColor!
Item was added:
+ ----- Method: SystemWindow>>delete (in category 'open/close') -----
+ delete
+ | thisWorld sketchEditor aPaintBox |
+ self mustNotClose ifTrue: [^self].
+ model okToClose ifFalse: [^self].
+ thisWorld := self world.
+ sketchEditor := self extantSketchEditor.
+ self isFlexed
+ ifTrue: [owner delete]
+ ifFalse: [super delete].
+ model windowIsClosing; release.
+ model := nil.
+ sketchEditor ifNotNil:
+ [sketchEditor deleteSelfAndSubordinates.
+ (thisWorld notNil
+ and: [(aPaintBox := thisWorld paintBoxOrNil) notNil]) ifTrue:
+ [aPaintBox delete]].
+
+ SystemWindow noteTopWindowIn: thisWorld!
Item was added:
+ ----- Method: SystemWindow>>deleteCloseBox (in category 'menu') -----
+ deleteCloseBox
+ closeBox ifNotNil:
+ [closeBox delete.
+ closeBox := nil]!
Item was added:
+ ----- Method: SystemWindow>>dimWindowButtons (in category 'top window') -----
+ dimWindowButtons
+ self == TopWindow ifFalse: [
+ {closeBox. collapseBox. menuBox. expandBox}
+ do: [:b | b ifNotNil: [b dim]]]!
Item was added:
+ ----- Method: SystemWindow>>doFastFrameDrag: (in category 'events') -----
+ doFastFrameDrag: grabPoint
+ "Do fast frame dragging from the given point"
+
+ | offset newBounds outerWorldBounds |
+ outerWorldBounds := self boundsIn: nil.
+ offset := outerWorldBounds origin - grabPoint.
+ newBounds := outerWorldBounds newRectFrom: [:f |
+ Sensor cursorPoint + offset extent: outerWorldBounds extent].
+ self position: (self globalPointToLocal: newBounds topLeft); comeToFront!
Item was added:
+ ----- Method: SystemWindow>>doFastWindowReframe: (in category 'resize/collapse') -----
+ doFastWindowReframe: ptName
+
+ | newBounds |
+ "For fast display, only higlight the rectangle during loop"
+ newBounds := self bounds newRectButtonPressedDo: [:f |
+ f
+ withSideOrCorner: ptName
+ setToPoint: (self pointFromWorld: Sensor cursorPoint)
+ minExtent: self minimumExtent].
+ self bounds: newBounds.
+ ^newBounds.!
Item was added:
+ ----- Method: SystemWindow>>existingPaneColor (in category 'colors handling') -----
+ existingPaneColor
+ "Answer the existing pane color for the window, obtaining it from the first paneMorph if any, and fall back on using the second stripe color if necessary."
+
+ | aColor |
+ aColor := self valueOfProperty: #paneColor.
+ aColor ifNil: [self setProperty: #paneColor toValue: (aColor := self paneColor)].
+ ^aColor.!
Item was added:
+ ----- Method: SystemWindow>>expand (in category 'resize/collapse') -----
+ expand
+ self isCollapsed ifTrue:[self collapseOrExpand]!
Item was added:
+ ----- Method: SystemWindow>>expandBoxHit (in category 'resize/collapse') -----
+ expandBoxHit
+ isCollapsed
+ ifTrue: [self hide;
+ collapseOrExpand;
+ expandToFullScreen;
+ show]
+ ifFalse: [self unexpandedFrame
+ ifNil: [self expandToFullScreen]
+ ifNotNil: [self contractToOriginalSize]]!
Item was added:
+ ----- Method: SystemWindow>>expandToFullScreen (in category 'resize/collapse') -----
+ expandToFullScreen
+ self unexpandedFrame ifNil: [ self unexpandedFrame: fullFrame ].
+ self fullScreen.
+ expandBox ifNotNil: [expandBox setBalloonText: 'contract to original size' translated]!
Item was added:
+ ----- Method: SystemWindow>>extantSketchEditor (in category 'top window') -----
+ extantSketchEditor
+ "If my world has an extant SketchEditorMorph associated with anything
+ in this window, return that SketchEditor, else return nil"
+ | w sketchEditor pasteUp |
+ (w := self world) isNil ifTrue: [^ nil].
+ (sketchEditor := w sketchEditorOrNil) isNil ifTrue: [^ nil].
+ (pasteUp := sketchEditor enclosingPasteUpMorph) isNil ifTrue: [^ nil].
+ self findDeepSubmorphThat: [:m | m = pasteUp]
+ ifAbsent: [^ nil].
+ ^ sketchEditor!
Item was added:
+ ----- Method: SystemWindow>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "Set the receiver's extent to value provided. Respect my minimumExtent."
+
+ | newExtent |
+ newExtent := self isCollapsed
+ ifTrue: [aPoint]
+ ifFalse: [aPoint max: self minimumExtent].
+ newExtent = self extent ifTrue: [^ self].
+
+ isCollapsed
+ ifTrue: [super extent: newExtent x @ (self labelHeight + 2)]
+ ifFalse: [super extent: newExtent].
+ isCollapsed
+ ifTrue: [collapsedFrame := self bounds]
+ ifFalse: [fullFrame := self bounds]!
Item was added:
+ ----- Method: SystemWindow>>fastFramingOn (in category 'resize/collapse') -----
+ fastFramingOn
+
+ ^ Preferences fastDragWindowForMorphic and: [self isFlexed not]!
Item was added:
+ ----- Method: SystemWindow>>fullFrame (in category 'resize/collapse') -----
+ fullFrame
+ ^ fullFrame!
Item was added:
+ ----- Method: SystemWindow>>fullScreen (in category 'menu') -----
+ fullScreen
+ "Zoom Window to full owner size, allowing for scroll bars and desk margins"
+
+ | left right possibleBounds |
+ left := right := 0.
+ self paneMorphs
+ do: [:pane | ((pane isKindOf: ScrollPane)
+ and: [pane retractableScrollBar])
+ ifTrue: [pane scrollBarOnLeft
+ ifTrue: [left := left max: pane scrollBarThickness]
+ ifFalse: [right := right max: pane scrollBarThickness]]].
+ possibleBounds := (RealEstateAgent maximumUsableAreaInWorld: self owner)
+ insetBy: (left @ 0 corner: right @ 0).
+ Preferences fullScreenLeavesDeskMargins
+ ifTrue: [possibleBounds := possibleBounds insetBy: 22].
+ self bounds: possibleBounds!
Item was added:
+ ----- Method: SystemWindow>>fullScreenMaximumExtent (in category 'menu') -----
+ fullScreenMaximumExtent
+ "Zoom Window to Full World size with possible DeskMargins
+ obey the maximum extent rules"
+
+ | left right possibleBounds |
+ left := right := 0.
+ self paneMorphs
+ do: [:pane | ((pane isKindOf: ScrollPane)
+ and: [pane retractableScrollBar])
+ ifTrue: [pane scrollBarOnLeft
+ ifTrue: [left := left max: pane scrollBarThickness]
+ ifFalse: [right := right max: pane scrollBarThickness]]].
+ possibleBounds := self worldBounds
+ insetBy: (left @ 0 corner: right @ 0).
+
+ self maximumExtent ifNotNil:
+ [possibleBounds := possibleBounds origin extent: ( self maximumExtent min: ( possibleBounds extent ))].
+ ((Flaps sharedFlapsAllowed
+ and: [Project current flapsSuppressed not])
+ or: [Preferences fullScreenLeavesDeskMargins])
+ ifTrue: [possibleBounds := possibleBounds insetBy: 22].
+ self bounds: possibleBounds!
Item was added:
+ ----- Method: SystemWindow>>getBoundsWithFlex (in category 'resize/collapse') -----
+ getBoundsWithFlex
+ "Return the lastest bounds rectangle with origin forced to global coordinates"
+
+ self isFlexed
+ ifTrue: [^ ((owner transform localPointToGlobal: bounds topLeft)
+ extent: bounds extent)]
+ ifFalse: [^ self bounds].
+ !
Item was added:
+ ----- Method: SystemWindow>>getCollapsedFrame (in category 'resize/collapse') -----
+ getCollapsedFrame
+
+ | tmp |
+ ^Preferences collapseWindowsInPlace
+ ifTrue:
+ [tmp := self getBoundsWithFlex.
+ tmp origin corner: (tmp corner x @ 18)]
+ ifFalse:
+ [RealEstateAgent assignCollapseFrameFor: self]!
Item was added:
+ ----- Method: SystemWindow>>getRawLabel (in category 'label') -----
+ getRawLabel
+ | contentsFit |
+ contentsFit := label duplicate fitContents.
+ contentsFit extent: (label extent x min: contentsFit extent x) @ contentsFit extent y.
+
+ ^ contentsFit
+ !
Item was added:
+ ----- Method: SystemWindow>>gradientWithColor: (in category 'colors handling') -----
+ gradientWithColor: aColor
+
+ | gradient |
+ gradient := GradientFillStyle ramp: {
+ 0.0 -> Color white.
+ 0.2 -> (aColor duller mixed: 0.5 with: (Color gray: 0.9)) lighter.
+ 1.0 -> aColor duller.
+ }.
+ gradient origin: self topLeft.
+ gradient direction: 0 @ self labelHeight.
+ ^gradient!
Item was added:
+ ----- Method: SystemWindow>>handleListenEvent: (in category 'events') -----
+ handleListenEvent: evt
+ "Make sure we lock our contents after DnD has finished"
+ evt isMouse ifFalse:[^self].
+ evt hand hasSubmorphs ifTrue:[^self]. "still dragging"
+ self == TopWindow ifFalse:[self lockInactivePortions].
+ evt hand removeMouseListener: self.!
Item was added:
+ ----- Method: SystemWindow>>handlesMouseDown: (in category 'events') -----
+ handlesMouseDown: evt
+
+ ^ true!
Item was added:
+ ----- Method: SystemWindow>>handlesMouseOverDragging: (in category 'events') -----
+ handlesMouseOverDragging: evt
+ ^true!
Item was added:
+ ----- Method: SystemWindow>>holdsTranscript (in category 'panes') -----
+ holdsTranscript
+ "ugh"
+ | plug |
+ ^ paneMorphs size = 1 and: [((plug := paneMorphs first) isKindOf: PluggableTextMorph) and: [plug model isKindOf: TranscriptStream]]!
Item was added:
+ ----- Method: SystemWindow>>icon (in category 'thumbnail') -----
+ icon
+ "Answer a form with an icon to represent the receiver"
+ ^ MenuIcons windowIcon!
Item was added:
+ ----- Method: SystemWindow>>initialExtent (in category 'open/close') -----
+ initialExtent
+ ^ Preferences bigDisplay
+ ifTrue: [(model initialExtent * 1.75) rounded]
+ ifFalse: [model initialExtent]!
Item was added:
+ ----- Method: SystemWindow>>initialize (in category 'initialization') -----
+ initialize
+ "Initialize a system window. Add label, stripes, etc., if desired"
+
+ super initialize.
+
+ self layoutPolicy: ProportionalLayout new.
+
+ self initializeLabelArea.
+ self addCornerGrips.
+ self setDefaultParameters.
+
+ allowReframeHandles := true.
+ isCollapsed := false.
+ activeOnlyOnTop := true.
+ paneMorphs := Array new.
+ mustNotClose := false.
+ updatablePanes := Array new.!
Item was added:
+ ----- Method: SystemWindow>>initializeLabelArea (in category 'initialization') -----
+ initializeLabelArea
+ "Initialize the label area (titlebar) for the window."
+
+ labelString ifNil: [labelString := 'Untitled Window'].
+ label := StringMorph new contents: labelString;
+ font: Preferences windowTitleFont emphasis: 0.
+ "Add collapse box so #labelHeight will work"
+ collapseBox := self createCollapseBox.
+ stripes := Array
+ with: (RectangleMorph newBounds: bounds)
+ with: (RectangleMorph newBounds: bounds).
+ "see extent:"
+ self addLabelArea.
+ self setLabelWidgetAllowance.
+ self addCloseBox.
+ self class moveMenuButtonRight
+ ifTrue: [self addLabel. self addMenuControl]
+ ifFalse: [self addMenuControl. self addLabel].
+ self addExpandBox.
+ labelArea addMorphBack: collapseBox.
+ self setFramesForLabelArea.
+ Preferences noviceMode
+ ifTrue: [closeBox
+ ifNotNil: [closeBox setBalloonText: 'close window'].
+ menuBox
+ ifNotNil: [menuBox setBalloonText: 'window menu'].
+ collapseBox
+ ifNotNil: [collapseBox setBalloonText: 'collapse/expand window']].
+ !
Item was added:
+ ----- Method: SystemWindow>>initializeWithLabel: (in category 'initialization') -----
+ initializeWithLabel: aString
+
+ labelString := aString.
+ self initialize.!
Item was added:
+ ----- Method: SystemWindow>>isActive (in category 'top window') -----
+ isActive
+ self activeOnlyOnTop ifTrue: [^ self == TopWindow].
+ ^ true!
Item was added:
+ ----- Method: SystemWindow>>isCollapsed (in category 'resize/collapse') -----
+ isCollapsed
+ ^ isCollapsed!
Item was added:
+ ----- Method: SystemWindow>>isSystemWindow (in category 'testing') -----
+ isSystemWindow
+ "answer whatever the receiver is a SystemWindow"
+ ^ true!
Item was added:
+ ----- Method: SystemWindow>>isWindowForModel: (in category 'testing') -----
+ isWindowForModel: aModel
+ "Return true if the receiver acts as the window for the given model"
+ ^aModel == self model!
Item was added:
+ ----- Method: SystemWindow>>justDroppedInto:event: (in category 'geometry') -----
+ justDroppedInto: aMorph event: anEvent
+
+ self hasDropShadow: (self isActive and: [Preferences menuAppearance3d]).
+
+ isCollapsed
+ ifTrue: [self position: ((self position max: 0 at 0) grid: 8 at 8).
+ collapsedFrame := self bounds]
+ ifFalse: [fullFrame := self bounds.
+ TopWindow ~~ self ifTrue: [self activate]].
+ ^super justDroppedInto: aMorph event: anEvent!
Item was added:
+ ----- Method: SystemWindow>>knownName (in category 'label') -----
+ knownName
+
+ ^ self label!
Item was added:
+ ----- Method: SystemWindow>>label (in category 'label') -----
+ label
+ ^ labelString!
Item was added:
+ ----- Method: SystemWindow>>labelHeight (in category 'label') -----
+ labelHeight
+ "Answer the height for the window label. The standard behavior is at bottom; a hook is provided so that models can stipulate other heights, in support of various less-window-looking demos."
+
+ | aHeight |
+ (model notNil and: [model respondsTo: #desiredWindowLabelHeightIn:]) ifTrue:
+ [(aHeight := model desiredWindowLabelHeightIn: self) ifNotNil: [^ aHeight]].
+
+ ^ label ifNil: [0] ifNotNil:
+ [(label height + (self class borderWidth * 2)) max:
+ (collapseBox ifNotNil: [collapseBox height] ifNil: [10])]!
Item was added:
+ ----- Method: SystemWindow>>labelRect (in category 'geometry') -----
+ labelRect
+ ^ self innerBounds withHeight: self labelHeight.
+ !
Item was added:
+ ----- Method: SystemWindow>>labelWidgetAllowance (in category 'label') -----
+ labelWidgetAllowance
+ ^ labelWidgetAllowance ifNil: [self setLabelWidgetAllowance]!
Item was added:
+ ----- Method: SystemWindow>>layoutBounds (in category 'layout') -----
+ layoutBounds
+ "Bounds of pane area only."
+ | box |
+
+ box := super layoutBounds.
+ ^box withTop: box top + self labelHeight!
Item was added:
+ ----- Method: SystemWindow>>lockInactivePortions (in category 'top window') -----
+ lockInactivePortions
+ "Make me unable to respond to mouse and keyboard. Control boxes remain active, except in novice mode"
+
+ self submorphsDo: [:m | m == labelArea ifFalse: [m lock]].
+ self dimWindowButtons.
+ labelArea ifNotNil:
+ [labelArea submorphsDo:
+ [:m |
+ (Preferences noviceMode or: [m ~~ closeBox and: [m ~~ collapseBox]])
+ ifTrue: [m lock]]]
+ ifNil: "i.e. label area is nil, so we're titleless"
+ [self adjustBorderUponDeactivationWhenLabeless].!
Item was added:
+ ----- Method: SystemWindow>>makeClosable (in category 'menu') -----
+ makeClosable
+ mustNotClose := false.
+ closeBox ifNil: [self addCloseBox]!
Item was added:
+ ----- Method: SystemWindow>>makeMeVisible (in category 'drawing') -----
+ makeMeVisible
+
+ self world extent > (0 at 0) ifFalse: [^ self].
+
+ ((self world bounds insetBy: (0 at 0 corner: self labelHeight asPoint))
+ containsPoint: self position) ifTrue: [^ self "OK -- at least my top left is visible"].
+
+ "window not on screen (probably due to reframe) -- move it now"
+ self isCollapsed
+ ifTrue: [self position: (RealEstateAgent assignCollapsePointFor: self)]
+ ifFalse: [self position: (RealEstateAgent initialFrameFor: self initialExtent: self extent world: self world) topLeft].
+
+ !
Item was added:
+ ----- Method: SystemWindow>>makeSecondTopmost (in category 'menu') -----
+ makeSecondTopmost
+ | aWorld nextWindow |
+ aWorld := self world.
+ nextWindow := aWorld submorphs
+ detect: [:m | (m isSystemWindow) and: [m ~~ self]]
+ ifNone: [^self].
+ nextWindow activate.
+ aWorld addMorph: self behind: nextWindow!
Item was added:
+ ----- Method: SystemWindow>>makeUnclosable (in category 'menu') -----
+ makeUnclosable
+ mustNotClose := true.
+ self deleteCloseBox!
Item was added:
+ ----- Method: SystemWindow>>maximumExtent (in category 'initialization') -----
+ maximumExtent
+ "This returns the maximum extent that the morph may be expanded to.
+ Return nil if this property has not been set."
+
+ ^ self valueOfProperty: #maximumExtent!
Item was added:
+ ----- Method: SystemWindow>>maximumExtent: (in category 'initialization') -----
+ maximumExtent: aPoint
+ "This returns the maximum extent that the morph may be expanded to.
+ Return nil if this property has not been set."
+
+ ^ self setProperty: #maximumExtent toValue: aPoint!
Item was added:
+ ----- Method: SystemWindow>>modalChild (in category 'polymorph') -----
+ modalChild
+ "Answer the modal child of the receiver, if any."
+
+ ^self valueOfProperty: #modalChild!
Item was added:
+ ----- Method: SystemWindow>>modalLockTo: (in category 'polymorph') -----
+ modalLockTo: aSystemWindow
+ "Lock the receiver as a modal owner of the given window."
+
+ aSystemWindow
+ setProperty: #modalOwner toValue: self.
+ self setProperty: #modalChild toValue: aSystemWindow!
Item was added:
+ ----- Method: SystemWindow>>modalOwner (in category 'polymorph') -----
+ modalOwner
+ "Answer the modal owner of the receiver, if any."
+
+ ^self valueOfProperty: #modalOwner!
Item was added:
+ ----- Method: SystemWindow>>modalUnlockFrom: (in category 'polymorph') -----
+ modalUnlockFrom: aSystemWindow
+ "Unlock the receiver as a modal owner of the given window."
+
+ aSystemWindow removeProperty: #modalOwner.
+ self removeProperty: #modalChild.
+ self activate!
Item was added:
+ ----- Method: SystemWindow>>model: (in category 'initialization') -----
+ model: anObject
+ super model: anObject.
+ self paneColor: nil.!
Item was added:
+ ----- Method: SystemWindow>>mouseDown: (in category 'events') -----
+ mouseDown: evt
+
+ | wasActive |
+ (wasActive := self isActive) ifFalse: [
+ evt hand releaseKeyboardFocus.
+ self activate].
+
+ wasActive
+ ifFalse: [
+ "the window was locked, thus we got the event.
+ re-send it now that the window is unlocked again"
+ evt wasHandled: false.
+ model windowActiveOnFirstClick
+ ifTrue: [self processEvent: evt] "re-dispatch to any submorphs"
+ ifFalse: [label processEvent: evt]. "dispatch to label so dragging works"
+ ]
+ ifTrue: [
+ evt hand
+ waitForClicksOrDrag: self
+ event: evt
+ selectors: { nil. nil. nil. #startDragFromLabel: }
+ threshold: HandMorph dragThreshold.
+ ].
+ evt wasHandled: true.!
Item was added:
+ ----- Method: SystemWindow>>mouseEnterDragging: (in category 'events') -----
+ mouseEnterDragging: evt
+ "unlock children for drop operations"
+ (self ~~ TopWindow and:[evt hand hasSubmorphs]) ifTrue:[
+ self submorphsDo:[:m| m unlock].
+ evt hand addMouseListener: self. "for drop completion on submorph"
+ ].!
Item was added:
+ ----- Method: SystemWindow>>mouseLeaveDragging: (in category 'events') -----
+ mouseLeaveDragging: evt
+ "lock children after drop operations"
+ (self ~~ TopWindow and:[evt hand hasSubmorphs]) ifTrue:[
+ self lockInactivePortions.
+ evt hand removeMouseListener: self.
+ ].!
Item was added:
+ ----- Method: SystemWindow>>mouseLeaveEvent:fromPane: (in category 'resize/collapse') -----
+ mouseLeaveEvent: event fromPane: pane
+ "For backward compatibility only. Not used by any newly created window"
+ (pane isKindOf: ScrollPane) ifTrue: [pane mouseLeave: event].
+ !
Item was added:
+ ----- Method: SystemWindow>>mouseUp: (in category 'events') -----
+ mouseUp: evt
+ | cp |
+ model windowActiveOnFirstClick ifTrue:
+ ["Normally window takes control on first click.
+ Need explicit transmission for first-click activity."
+ cp := evt cursorPoint.
+ submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseUp: evt]]]!
Item was added:
+ ----- Method: SystemWindow>>mustNotClose (in category 'open/close') -----
+ mustNotClose
+ ^ mustNotClose == true!
Item was added:
+ ----- Method: SystemWindow>>offerWindowMenu (in category 'menu') -----
+ offerWindowMenu
+ | aMenu |
+ aMenu := self buildWindowMenu.
+ model ifNotNil:
+ [model addModelItemsToWindowMenu: aMenu].
+ aMenu popUpEvent: self currentEvent in: self world!
Item was added:
+ ----- Method: SystemWindow>>openAsIs (in category 'open/close') -----
+ openAsIs
+ ^self openAsIsIn: self currentWorld
+ !
Item was added:
+ ----- Method: SystemWindow>>openAsIsIn: (in category 'open/close') -----
+ openAsIsIn: aWorld
+ "This msg and its callees result in the window being activeOnlyOnTop"
+ aWorld addMorph: self.
+ self activate.
+ aWorld startSteppingSubmorphsOf: self.
+ self activeHand releaseAllFoci!
Item was added:
+ ----- Method: SystemWindow>>openInWorld: (in category 'open/close') -----
+ openInWorld: aWorld
+ "This msg and its callees result in the window being activeOnlyOnTop"
+ [^ self anyOpenWindowLikeMe
+ ifEmpty:
+ [ self
+ bounds: (RealEstateAgent initialFrameFor: self world: aWorld) ;
+ openAsIsIn: aWorld ]
+ ifNotEmptyDo:
+ [ : windows |
+ windows anyOne
+ expand ;
+ activate ;
+ postAcceptBrowseFor: self ].
+ ] ensure: [ self activeHand releaseAllFoci ]!
Item was added:
+ ----- Method: SystemWindow>>openInWorld:extent: (in category 'open/close') -----
+ openInWorld: aWorld extent: extent
+ "This msg and its callees result in the window being activeOnlyOnTop"
+ [^ self anyOpenWindowLikeMe
+ ifEmpty:
+ [ self
+ position: (RealEstateAgent initialFrameFor: self initialExtent: extent world: aWorld) topLeft ;
+ extent: extent.
+ self openAsIsIn: aWorld ]
+ ifNotEmptyDo:
+ [ : windows |
+ windows anyOne
+ expand ;
+ activate ;
+ postAcceptBrowseFor: self ].
+ ] ensure: [ self activeHand releaseAllFoci ]!
Item was added:
+ ----- Method: SystemWindow>>openInWorldExtent: (in category 'open/close') -----
+ openInWorldExtent: extent
+ "This msg and its callees result in the window being activeOnlyOnTop"
+ ^ self openInWorld: self currentWorld extent: extent!
Item was added:
+ ----- Method: SystemWindow>>paneColor (in category 'colors handling') -----
+ paneColor
+ | cc |
+ (cc := self valueOfProperty: #paneColor) ifNotNil: [^cc].
+ Display depth > 2
+ ifTrue:
+ [model ifNotNil:
+ [model isInMemory
+ ifTrue:
+ [cc := Color colorFrom: model defaultBackgroundColor]].
+ cc ifNil: [cc := paneMorphs isEmptyOrNil ifFalse: [paneMorphs first color]]].
+ cc ifNil: [cc := self defaultBackgroundColor].
+ self paneColor: cc.
+ ^cc!
Item was added:
+ ----- Method: SystemWindow>>paneColor: (in category 'colors handling') -----
+ paneColor: aColor
+ self setProperty: #paneColor toValue: aColor.
+
+ self adoptPaneColor: aColor.!
Item was added:
+ ----- Method: SystemWindow>>paneColorToUse (in category 'colors handling') -----
+ paneColorToUse
+ ^ Display depth <= 2
+ ifTrue:
+ [Color white]
+ ifFalse:
+ [self paneColor]!
Item was added:
+ ----- Method: SystemWindow>>paneColorToUseWhenNotActive (in category 'colors handling') -----
+ paneColorToUseWhenNotActive
+
+ ^ self paneColorToUse darker!
Item was added:
+ ----- Method: SystemWindow>>paneMorphSatisfying: (in category 'panes') -----
+ paneMorphSatisfying: aBlock
+
+ ^paneMorphs detect: aBlock ifNone: [ nil ]!
Item was added:
+ ----- Method: SystemWindow>>paneMorphs (in category 'geometry') -----
+ paneMorphs
+ "Nominally private but a need for obtaining this from the outside arose"
+ ^ paneMorphs copy!
Item was added:
+ ----- Method: SystemWindow>>paneTransition: (in category 'events') -----
+ paneTransition: event
+ "Mouse has entered or left a pane"!
Item was added:
+ ----- Method: SystemWindow>>paneWithLongestSide:near: (in category 'resize/collapse') -----
+ paneWithLongestSide: sideBlock near: aPoint
+ | thePane theSide theLen |
+ theLen := 0.
+ paneMorphs do:
+ [:pane | | box |
+ box := pane bounds.
+ box forPoint: aPoint closestSideDistLen:
+ [:side :dist :len |
+ (dist <= 5 and: [len > theLen]) ifTrue:
+ [thePane := pane.
+ theSide := side.
+ theLen := len]]].
+ sideBlock value: theSide.
+ ^ thePane!
Item was added:
+ ----- Method: SystemWindow>>panelRect (in category 'geometry') -----
+ panelRect
+ "Answer the area below the title bar which is devoted to panes."
+
+ ^ self innerBounds insetBy: (0 @ self labelHeight corner: 0 @ 0)!
Item was added:
+ ----- Method: SystemWindow>>passivate (in category 'top window') -----
+ passivate
+ "Make me unable to respond to mouse and keyboard"
+
+ label ifNotNil: [label color: Color darkGray].
+
+ self hasDropShadow: false.
+ self paneColorToUseWhenNotActive in: [:c |
+ self
+ setStripeColorsFrom: c;
+ adoptPaneColor: c].
+
+ model modelSleep.
+
+ self lockInactivePortions
+ !
Item was added:
+ ----- Method: SystemWindow>>position: (in category 'geometry') -----
+ position: newPos
+ super position: newPos.
+ isCollapsed
+ ifTrue: [collapsedFrame := self bounds]
+ ifFalse: [fullFrame := self bounds].
+ !
Item was added:
+ ----- Method: SystemWindow>>positionSubmorphs (in category 'open/close') -----
+ positionSubmorphs
+ "Feels like overkill, but effect needed"
+ super positionSubmorphs.
+ self submorphsDo:
+ [:aMorph | aMorph positionSubmorphs]!
Item was added:
+ ----- Method: SystemWindow>>postAcceptBrowseFor: (in category 'open/close') -----
+ postAcceptBrowseFor: anotherSystemWindow
+ "If I am taking over browsing for anotherSystemWindow, sucblasses may override to, for example, position me to the object to be focused on."
+ self model postAcceptBrowseFor: anotherSystemWindow model!
Item was added:
+ ----- Method: SystemWindow>>putLabelItemsInLabelArea (in category 'layout') -----
+ putLabelItemsInLabelArea
+ "Put label items into the label area, if there is one"
+
+ labelArea ifNotNil:
+ [stripes ifNotNil: [stripes do: [:stripe | labelArea addMorph: stripe]].
+ closeBox ifNotNil: [labelArea addMorph: closeBox].
+ menuBox ifNotNil: [labelArea addMorph: menuBox].
+ collapseBox ifNotNil: [labelArea addMorph: collapseBox].
+ label ifNotNil: [labelArea addMorph: label]]
+
+ !
Item was added:
+ ----- Method: SystemWindow>>raisedColor (in category 'colors handling') -----
+ raisedColor
+ ^self paneColor raisedColor!
Item was added:
+ ----- Method: SystemWindow>>reframePanesAdjoining:along:to: (in category 'resize/collapse') -----
+ reframePanesAdjoining: growingPane along: side to: aDisplayBox
+ | delta newRect minDim theMin horiz |
+ growingPane ifNil: [^ self]. "As from click outside"
+ newRect := aDisplayBox.
+ horiz := #(left right) includes: side.
+ theMin := horiz ifTrue: [40] ifFalse: [20].
+
+ "First check that this won't make any pane smaller than theMin screen dots"
+ minDim := (((paneMorphs select: [:pane | pane bounds bordersOn: growingPane bounds along: side])
+ collect: [:pane | pane bounds adjustTo: newRect along: side]) copyWith: aDisplayBox)
+ inject: 999 into:
+ [:was :rect | was min: (horiz ifTrue: [rect width] ifFalse: [rect height])].
+ "If so, amend newRect as required"
+ minDim > theMin ifFalse:
+ [delta := minDim - theMin.
+ newRect := newRect withSide: side setTo:
+ ((newRect perform: side) > (growingPane bounds perform: side)
+ ifTrue: [(newRect perform: side) + delta]
+ ifFalse: [(newRect perform: side) - delta])].
+
+ "Now adjust all adjoining panes for real"
+ paneMorphs do:
+ [:pane | (pane bounds bordersOn: growingPane bounds along: side) ifTrue:
+ [pane bounds: (pane bounds adjustTo: newRect along: side)]].
+ "And adjust the growing pane itself"
+ growingPane bounds: newRect.
+
+ "Finally force a recomposition of the whole window"
+ self setPaneRectsFromBounds.
+ self extent: self extent!
Item was added:
+ ----- Method: SystemWindow>>refreshWindowColor (in category 'colors handling') -----
+ refreshWindowColor
+ "For changing the underlying model's default window color"
+ self setProperty: #paneColor toValue: nil.
+ self setWindowColor: self paneColor.
+
+ "Reset colors if we are not active."
+ self isActive ifFalse: [
+ self paneColorToUseWhenNotActive in: [:c |
+ self
+ setStripeColorsFrom: c;
+ adoptPaneColor: c]].!
Item was added:
+ ----- Method: SystemWindow>>relabel (in category 'label') -----
+ relabel
+ | newLabel |
+ newLabel := UIManager default
+ request: 'New title for this window' translated
+ initialAnswer: labelString.
+ newLabel isEmpty ifTrue: [^self].
+ (model windowReqNewLabel: newLabel)
+ ifTrue: [self setLabel: newLabel]!
Item was added:
+ ----- Method: SystemWindow>>relabelEvent: (in category 'label') -----
+ relabelEvent: evt
+ "No longer used, but may be referred to by old eventHandlers"
+
+ ^ Preferences clickOnLabelToEdit
+ ifFalse: [self mouseDown: evt]
+ ifTrue: [self relabel]!
Item was added:
+ ----- Method: SystemWindow>>rememberedKeyboardFocus (in category 'polymorph') -----
+ rememberedKeyboardFocus
+ "Answer the remembered keyboard focus for the receiver."
+
+ ^self valueOfProperty: #rememberedFocus!
Item was added:
+ ----- Method: SystemWindow>>removeMenuBox (in category 'geometry') -----
+ removeMenuBox
+ menuBox ifNotNil:
+ [menuBox delete.
+ menuBox := nil].
+ !
Item was added:
+ ----- Method: SystemWindow>>replaceBoxes (in category 'initialization') -----
+ replaceBoxes
+ "Rebuild the various boxes."
+ self setLabelWidgetAllowance.
+ label ifNotNil: [label delete].
+ labelArea ifNotNil: [labelArea delete].
+ self initializeLabelArea.
+ self setFramesForLabelArea.
+ self setWindowColor: self paneColor.
+ self isActive ifFalse: [self passivate].!
Item was added:
+ ----- Method: SystemWindow>>replacePane:with: (in category 'panes') -----
+ replacePane: oldPane with: newPane
+ "Make newPane exactly occupy the position and extent of oldPane"
+
+ | aLayoutFrame hadDep |
+ hadDep := model dependents includes: oldPane.
+ oldPane owner replaceSubmorph: oldPane by: newPane.
+ newPane
+ position: oldPane position;
+ extent: oldPane extent.
+ aLayoutFrame := oldPane layoutFrame.
+ paneMorphs := paneMorphs collect:
+ [:each |
+ each == oldPane ifTrue: [newPane] ifFalse: [each]].
+ aLayoutFrame ifNotNil: [newPane layoutFrame: aLayoutFrame].
+ newPane color: Color transparent.
+ hadDep ifTrue: [model removeDependent: oldPane. model addDependent: newPane].
+
+ self changed
+
+ !
Item was added:
+ ----- Method: SystemWindow>>restoreDefaultPaneColor (in category 'colors handling') -----
+ restoreDefaultPaneColor
+ "Useful when changing from monochrome to color display"
+
+ self setStripeColorsFrom: self paneColor.!
Item was added:
+ ----- Method: SystemWindow>>secondaryPaneTransition:divider: (in category 'events') -----
+ secondaryPaneTransition: event divider: aMorph
+ "Mouse has entered or left a pane"!
Item was added:
+ ----- Method: SystemWindow>>sendToBack (in category 'menu') -----
+ sendToBack
+ | aWorld nextWindow |
+ aWorld := self world.
+ nextWindow := aWorld submorphs
+ detect: [:m | (m isSystemWindow) and: [m ~~ self]]
+ ifNone: [^self].
+ nextWindow activate.
+ aWorld addMorphNearBack: self!
Item was added:
+ ----- Method: SystemWindow>>setBoundsWithFlex: (in category 'resize/collapse') -----
+ setBoundsWithFlex: newFrame
+ "Set bounds from newFrame with origin preserved from global coordinates"
+
+ self isFlexed
+ ifTrue: [super bounds: ((owner transform globalPointToLocal: newFrame topLeft)
+ extent: newFrame extent)]
+ ifFalse: [super bounds: newFrame].!
Item was added:
+ ----- Method: SystemWindow>>setDefaultParameters (in category 'initialization') -----
+ setDefaultParameters
+
+ Preferences menuAppearance3d ifTrue: [
+ self hasDropShadow: self isActive.
+
+ self useSoftDropShadow
+ ifTrue: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.01);
+ shadowOffset: (10 at 8 corner: 10 at 12)]
+ ifFalse: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.333);
+ shadowOffset: 1 at 1] ].
+ self changed.!
Item was added:
+ ----- Method: SystemWindow>>setFramesForLabelArea (in category 'initialization') -----
+ setFramesForLabelArea
+ "an aid to converting old instances, but then I found
+ convertAlignment (jesse welton's note)"
+ | frame windowBorderWidth |
+ labelArea ifNil: [^ self].
+ labelArea
+ layoutPolicy: TableLayout new;
+ listDirection: #leftToRight;
+ hResizing: #spaceFill;
+ layoutInset: 0.
+ label hResizing: #spaceFill.
+ labelArea
+ ifNotNil: [frame := LayoutFrame new.
+ frame leftFraction: 0;
+ topFraction: 0;
+ rightFraction: 1;
+ bottomFraction: 0;
+ topOffset: self labelHeight negated.
+ windowBorderWidth := self class borderWidth.
+ frame leftOffset: windowBorderWidth;
+ rightOffset: windowBorderWidth negated;
+ topOffset: self labelHeight negated + windowBorderWidth;
+ bottomOffset: windowBorderWidth negated.
+ labelArea layoutFrame: frame]!
Item was added:
+ ----- Method: SystemWindow>>setLabel: (in category 'label') -----
+ setLabel: aString
+ | frame |
+ labelString := aString.
+ label ifNil: [^ self].
+ label contents: (aString ifNil: ['']).
+ self labelWidgetAllowance. "Sets it if not already"
+ self isCollapsed
+ ifTrue: [self extent: (label width + labelWidgetAllowance) @ (self labelHeight + 2)]
+ ifFalse: [label fitContents; setWidth: (label width min: bounds width - labelWidgetAllowance).
+ label align: label bounds topCenter with: bounds topCenter + (0 at borderWidth).
+ collapsedFrame ifNotNil:
+ [collapsedFrame := collapsedFrame withWidth: label width + labelWidgetAllowance]].
+ frame := LayoutFrame new.
+ frame leftFraction: 0.5;
+ topFraction: 0.5;
+ leftOffset: label width negated // 2;
+ topOffset: label height negated // 2.
+ label layoutFrame: frame.
+ !
Item was added:
+ ----- Method: SystemWindow>>setLabelFont: (in category 'label') -----
+ setLabelFont: aFont
+
+ label ifNil: [^ self].
+ label font: aFont.
+ !
Item was added:
+ ----- Method: SystemWindow>>setLabelWidgetAllowance (in category 'label') -----
+ setLabelWidgetAllowance
+ ^ labelWidgetAllowance := (self boxExtent x * 4) + 19!
Item was added:
+ ----- Method: SystemWindow>>setPaneRectsFromBounds (in category 'geometry') -----
+ setPaneRectsFromBounds
+ "Reset proportional specs from actual bounds, eg, after reframing panes"
+ | layoutBounds |
+ layoutBounds := self layoutBounds.
+ paneMorphs do:[:m| | box left bottom top frame right |
+ frame := m layoutFrame.
+ box := m bounds.
+ frame ifNotNil:[
+ left := box left - layoutBounds left - (frame leftOffset ifNil:[0]).
+ right := box right - layoutBounds left - (frame rightOffset ifNil:[0]).
+ top := box top - layoutBounds top - (frame topOffset ifNil:[0]).
+ bottom := box bottom - layoutBounds top - (frame bottomOffset ifNil:[0]).
+ frame leftFraction: (left / layoutBounds width asFloat).
+ frame rightFraction: (right / layoutBounds width asFloat).
+ frame topFraction: (top / layoutBounds height asFloat).
+ frame bottomFraction: (bottom / layoutBounds height asFloat).
+ ].
+ ].!
Item was added:
+ ----- Method: SystemWindow>>setStripeColorsFrom: (in category 'colors handling') -----
+ setStripeColorsFrom: paneColor
+ "Set the stripe color based on the given paneColor"
+
+ labelArea ifNotNil: [labelArea color: Color transparent].
+ self updateBoxesColor: paneColor.
+ stripes ifNil: [^self].
+
+ self borderColor: (paneColor adjustBrightness: -0.3).
+
+ self class gradientWindow
+ ifTrue: [self fillStyle: (self gradientWithColor: paneColor)]
+ ifFalse: [self color: paneColor].!
Item was added:
+ ----- Method: SystemWindow>>setUpdatablePanesFrom: (in category 'panes') -----
+ setUpdatablePanesFrom: getSelectors
+ | aList possibles |
+ "Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors. Order is important here!! Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case"
+
+ aList := OrderedCollection new.
+ possibles := OrderedCollection new.
+ self allMorphsDo: [ :pane |
+ (pane isKindOf: PluggableListMorph) ifTrue: [
+ possibles add: pane.
+ ].
+ ].
+
+ getSelectors do: [:sel | | aPane |
+ aPane := possibles detect: [ :pane | pane getListSelector == sel] ifNone: [nil].
+ aPane
+ ifNotNil:
+ [aList add: aPane]
+ ifNil:
+ [Transcript cr; show: 'Warning: pane ', sel, ' not found.']].
+ updatablePanes := aList asArray!
Item was added:
+ ----- Method: SystemWindow>>setWindowColor (in category 'menu') -----
+ setWindowColor
+ "Allow the user to select a new basic color for the window"
+ NewColorPickerMorph useIt
+ ifTrue:
+ [ (NewColorPickerMorph
+ on: self
+ originalColor: self paneColorToUse
+ setColorSelector: #setWindowColor:) openNear: self fullBounds ]
+ ifFalse:
+ [ ColorPickerMorph new
+ choseModalityFromPreference ;
+ sourceHand: self activeHand ;
+ target: self ;
+ selector: #setWindowColor: ;
+ originalColor: self paneColorToUse ;
+
+ putUpFor: self
+ near: self fullBounds ]!
Item was added:
+ ----- Method: SystemWindow>>setWindowColor: (in category 'colors handling') -----
+ setWindowColor: incomingColor
+ | existingColor aColor |
+ incomingColor ifNil: [^ self]. "it happens"
+ aColor := incomingColor.
+ (aColor = ColorPickerMorph perniciousBorderColor
+ or: [aColor = Color black]) ifTrue: [^ self].
+ existingColor := self paneColorToUse.
+ existingColor ifNil: [^ Beeper beep].
+ self paneColor: aColor.
+ self setStripeColorsFrom: aColor.
+ self changed.!
Item was added:
+ ----- Method: SystemWindow>>shouldDropOnMouseUp (in category 'testing') -----
+ shouldDropOnMouseUp
+ "Return true for consistency with fastdrag"
+ ^true!
Item was added:
+ ----- Method: SystemWindow>>startDragFromLabel: (in category 'events') -----
+ startDragFromLabel: evt
+ "When label events are active, we need to pass dragging to the window explicitely
+ The window only recognizes a drag with an offset of more than 3 pixels"
+
+ self isSticky ifTrue: [^ self].
+ self fastFramingOn
+ ifTrue: [self doFastFrameDrag: evt cursorPoint]
+ ifFalse: [
+ self hasDropShadow: false.
+ evt hand grabMorph: self topRendererOrSelf]
+ !
Item was added:
+ ----- Method: SystemWindow>>stepAt: (in category 'stepping') -----
+ stepAt: millisecondClockValue
+ "If the receiver is not collapsed, step it, after first stepping the model."
+
+ (isCollapsed not or: [self wantsStepsWhenCollapsed]) ifTrue:
+ [model ifNotNil: [model stepAt: millisecondClockValue in: self].
+ super stepAt: millisecondClockValue "let player, if any, step"]
+
+ "Since this method ends up calling step, the model-stepping logic should not be duplicated there."!
Item was added:
+ ----- Method: SystemWindow>>stepTime (in category 'stepping') -----
+ stepTime
+ ^ model
+ ifNotNil:
+ [model stepTimeIn: self]
+ ifNil:
+ [200] "milliseconds"!
Item was added:
+ ----- Method: SystemWindow>>takeOutOfWindow (in category 'menu') -----
+ takeOutOfWindow
+ "Take the receiver's pane morph out the window and place it, naked, where once the window was"
+ | aMorph |
+ paneMorphs size = 1 ifFalse: [^ Beeper beep].
+ aMorph := paneMorphs first.
+ owner addMorphFront: aMorph.
+ self delete!
Item was added:
+ ----- Method: SystemWindow>>titleAndPaneText (in category 'panes') -----
+ titleAndPaneText
+ "If the receiver represents a workspace, return an Association between the title and that text, else return nil"
+ (paneMorphs size ~= 1 or: [(paneMorphs first isKindOf: PluggableTextMorph) not])
+ ifTrue: [^ nil].
+ ^ labelString -> paneMorphs first text
+
+ !
Item was added:
+ ----- Method: SystemWindow>>tryToRenameTo: (in category 'label') -----
+ tryToRenameTo: newLabel
+ "Triggered eg by typing a new name in the halo"
+
+ newLabel isEmpty ifTrue: [^self].
+ (model windowReqNewLabel: newLabel)
+ ifTrue: [self setLabel: newLabel]
+ !
Item was added:
+ ----- Method: SystemWindow>>undimWindowButtons (in category 'top window') -----
+ undimWindowButtons
+ {closeBox. collapseBox. menuBox. expandBox}
+ do: [:b | b ifNotNil: [b undim]]!
Item was added:
+ ----- Method: SystemWindow>>unexpandedFrame (in category 'resize/collapse') -----
+ unexpandedFrame
+ "Return the frame size of an unexpanded window"
+
+ ^ self valueOfProperty: #unexpandedFrame!
Item was added:
+ ----- Method: SystemWindow>>unexpandedFrame: (in category 'resize/collapse') -----
+ unexpandedFrame: aRectangle
+ "Set the frame size of an unexpanded window"
+
+ ^ self setProperty: #unexpandedFrame toValue: aRectangle!
Item was added:
+ ----- Method: SystemWindow>>updatablePanes (in category 'panes') -----
+ updatablePanes
+ "Answer the list of panes, in order, which should be sent the #verifyContents message"
+ ^ updatablePanes ifNil: [updatablePanes := #()]!
Item was added:
+ ----- Method: SystemWindow>>update: (in category 'label') -----
+ update: aSymbol
+ aSymbol = #relabel
+ ifTrue: [^ model ifNotNil: [ self setLabel: model labelString ] ].
+ aSymbol = #close
+ ifTrue: [self delete]!
Item was added:
+ ----- Method: SystemWindow>>updateBox:color: (in category 'panes') -----
+ updateBox: anIconMorph color: aColor
+
+ | fill |
+ anIconMorph isNil
+ ifTrue: [^ self].
+ anIconMorph
+ extent: self boxExtent;
+ useRoundedCorners.
+
+ SystemWindow gradientWindow
+ ifFalse: [anIconMorph color: aColor]
+ ifTrue: [
+ fill := GradientFillStyle ramp: {
+ 0.0 -> aColor muchLighter muchLighter.
+ 1.0 -> aColor twiceDarker}.
+ fill origin: anIconMorph topLeft + (5 @ 5).
+ fill direction: anIconMorph extent.
+ anIconMorph fillStyle: fill].
+
+ anIconMorph
+ borderWidth: (Preferences alternativeWindowBoxesLook
+ ifTrue: [1]
+ ifFalse: [0]);
+ borderColor: aColor darker.!
Item was added:
+ ----- Method: SystemWindow>>updateBoxesColor: (in category 'panes') -----
+ updateBoxesColor: aColor
+ | opaqueColor |
+ aColor isNil
+ ifTrue: [^ self].
+ Preferences alternativeWindowBoxesLook ifFalse:[^ self].
+
+ opaqueColor := aColor asNontranslucentColor.
+
+ self
+ updateBox: closeBox
+ color: (opaqueColor alphaMixed: 0.5 with: Color red).
+ self updateBox: menuBox color: opaqueColor.
+ self updateBox: expandBox color: opaqueColor.
+ self updateBox: collapseBox color: opaqueColor!
Item was added:
+ ----- Method: SystemWindow>>updatePaneColors (in category 'colors handling') -----
+ updatePaneColors
+ "Useful when changing from monochrome to color display"
+
+ self setStripeColorsFrom: self paneColorToUse.!
Item was added:
+ ----- Method: SystemWindow>>updatePanesFromSubmorphs (in category 'top window') -----
+ updatePanesFromSubmorphs
+ "Having removed some submorphs, make sure this is reflected in my paneMorphs."
+ paneMorphs := paneMorphs select: [ :pane | submorphs includes: pane ].!
Item was added:
+ ----- Method: SystemWindow>>wantsExpandBox (in category 'resize/collapse') -----
+ wantsExpandBox
+ "Answer whether I'd like an expand box"
+
+ ^ Preferences alwaysHideExpandButton not!
Item was added:
+ ----- Method: SystemWindow>>wantsHalo (in category 'events') -----
+ wantsHalo
+ ^ false!
Item was added:
+ ----- Method: SystemWindow>>wantsRoundedCorners (in category 'drawing') -----
+ wantsRoundedCorners
+ ^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]!
Item was added:
+ ----- Method: SystemWindow>>wantsSteps (in category 'stepping') -----
+ wantsSteps
+ "Return true if the model wants its view to be stepped. For an open system window, we give the model to offer an opinion"
+
+ self isPartsDonor ifTrue: [^ false].
+ self player wantsSteps ifTrue: [^ true].
+ ^ isCollapsed not and: [model wantsStepsIn: self]!
Item was added:
+ ----- Method: SystemWindow>>wantsStepsWhenCollapsed (in category 'stepping') -----
+ wantsStepsWhenCollapsed
+ "Default is not to bother updating collapsed windows"
+
+ ^ false!
Item was added:
+ ----- Method: SystemWindow>>wantsToBeCachedByHand (in category 'testing') -----
+ wantsToBeCachedByHand
+ "Return true if the receiver wants to be cached by the hand when it is dragged around."
+ self hasTranslucentColor ifTrue:[^false].
+ self bounds = self fullBounds ifTrue:[^true].
+ self submorphsDo:[:m|
+ (self bounds containsRect: m fullBounds) ifFalse:[
+ m wantsToBeCachedByHand ifFalse:[^false].
+ ].
+ ].
+ ^true!
Item was added:
+ ----- Method: SystemWindow>>wantsToBeDroppedInto: (in category 'events') -----
+ wantsToBeDroppedInto: aMorph
+ "Return true if it's okay to drop the receiver into aMorph"
+ ^aMorph isWorldMorph or:[Preferences systemWindowEmbedOK]!
Item was added:
+ ----- Method: SystemWindow>>wantsYellowButtonMenu (in category 'menu') -----
+ wantsYellowButtonMenu
+ "Answer true if the receiver wants a yellow button menu"
+ ^ false!
Item was added:
+ ----- Method: SystemWindow>>widthOfFullLabelText (in category 'label') -----
+ widthOfFullLabelText
+ ^Preferences windowTitleFont widthOfString: labelString!
Item was added:
+ IconicButton subclass: #SystemWindowButton
+ instanceVariableNames: 'dimmed dimmedForm highlightedForm'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: SystemWindowButton>>dim (in category 'visual properties') -----
+ dim
+ dimmed := true.
+ self restoreImage.!
Item was added:
+ ----- Method: SystemWindowButton>>dimmedForm (in category 'visual properties') -----
+ dimmedForm
+ ^ dimmedForm ifNil: [ dimmedForm := self firstSubmorph baseGraphic dimmed ]!
Item was added:
+ ----- Method: SystemWindowButton>>handlesMouseOver: (in category 'visual properties') -----
+ handlesMouseOver: evt
+
+ ^ true
+ !
Item was added:
+ ----- Method: SystemWindowButton>>highlight (in category 'visual properties') -----
+ highlight
+
+ self firstSubmorph form: self highlightedForm
+ !
Item was added:
+ ----- Method: SystemWindowButton>>highlightedForm (in category 'visual properties') -----
+ highlightedForm
+ ^ highlightedForm ifNil: [ highlightedForm := self firstSubmorph baseGraphic lighter ]!
Item was added:
+ ----- Method: SystemWindowButton>>lock (in category 'accessing') -----
+ lock
+ self firstSubmorph form: self dimmedForm.
+ super lock!
Item was added:
+ ----- Method: SystemWindowButton>>mouseEnter: (in category 'visual properties') -----
+ mouseEnter: evt
+
+ self highlight.
+ !
Item was added:
+ ----- Method: SystemWindowButton>>mouseLeave: (in category 'visual properties') -----
+ mouseLeave: evt
+
+ self restoreImage.
+ !
Item was added:
+ ----- Method: SystemWindowButton>>restoreImage (in category 'visual properties') -----
+ restoreImage
+ dimmed == true
+ ifTrue: [self firstSubmorph form: self dimmedForm]
+ ifFalse: [super restoreImage]
+ !
Item was added:
+ ----- Method: SystemWindowButton>>undim (in category 'visual properties') -----
+ undim
+ dimmed := false..
+ self isLocked ifFalse: [self restoreImage].!
Item was added:
+ ----- Method: SystemWindowButton>>unlock (in category 'accessing') -----
+ unlock
+ self restoreImage.
+ super unlock!
Item was added:
+ ----- Method: SystemWindowButton>>updateVisualState: (in category 'visual properties') -----
+ updateVisualState: evt
+
+ (self containsPoint: evt cursorPoint)
+ ifTrue: [self darken]
+ ifFalse: [self restoreImage].
+ !
Item was added:
+ SystemWindow subclass: #SystemWindowWithButton
+ instanceVariableNames: 'buttonInTitle'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !SystemWindowWithButton commentStamp: '<historical>' prior: 0!
+ A SystemWindow with a single extra button in its title bar.!
Item was added:
+ ----- Method: SystemWindowWithButton class>>hideExpandButton (in category 'preferences') -----
+ hideExpandButton
+
+ ^ true!
Item was added:
+ ----- Method: SystemWindowWithButton>>adjustExtraButton (in category 'geometry') -----
+ adjustExtraButton
+ | leftMargin |
+ buttonInTitle ifNil: [^ self].
+ leftMargin := self boxExtent x + 3.
+ self class moveMenuButtonRight ifTrue: [leftMargin := leftMargin * 2].
+ buttonInTitle align: buttonInTitle topRight with: self innerBounds topRight - (leftMargin at 0)!
Item was added:
+ ----- Method: SystemWindowWithButton>>buttonInTitle: (in category 'label') -----
+ buttonInTitle: aButton
+ buttonInTitle := aButton.
+ self addMorphFront: aButton!
Item was added:
+ ----- Method: SystemWindowWithButton>>extent: (in category 'geometry') -----
+ extent: newExtent
+ super extent: (newExtent max: 120 @ 50).
+ self adjustExtraButton!
Item was added:
+ ----- Method: SystemWindowWithButton>>setLabelWidgetAllowance (in category 'label') -----
+ setLabelWidgetAllowance
+ ^ labelWidgetAllowance := 115!
Item was added:
+ ----- Method: SystemWindowWithButton>>wantsExpandBox (in category 'resize/collapse') -----
+ wantsExpandBox
+ "Answer whether I'd like an expand box"
+
+ ^ false!
Item was added:
+ ----- Method: TTCFont>>computeForm: (in category '*Morphic-Multilingual') -----
+ computeForm: char
+ "Compute the glyph form for the given character"
+ ^ttcDescription renderGlyph: char height: self height fgColor: foregroundColor bgColor: Color transparent depth: self depth!
Item was added:
+ ----- Method: TTCFont>>fallbackForm (in category '*Morphic-Multilingual') -----
+ fallbackForm
+ "Compute the glyph form for the fallback glyph"
+ ^ttcDescription renderFallbackGlyphOfHeight: self height fgColor: foregroundColor bgColor: Color transparent depth: self depth!
Item was added:
+ ----- Method: TTFontDescription>>asMorph (in category '*Morphic-TrueType') -----
+ asMorph
+ ^TTSampleFontMorph font: self!
Item was added:
+ ----- Method: TTGlyph>>asFormWithScale:ascender:descender: (in category '*Morphic-Multilingual') -----
+ asFormWithScale: scale ascender: ascender descender: descender
+ ^ self
+ asFormWithScale: scale
+ ascender: ascender
+ descender: descender
+ fgColor: Color black
+ bgColor: Color white
+ depth: 8
+ replaceColor: true.
+ !
Item was added:
+ ----- Method: TTGlyph>>asFormWithScale:ascender:descender:fgColor:bgColor:depth: (in category '*Morphic-Multilingual') -----
+ asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth
+
+ ^ self
+ asFormWithScale: scale
+ ascender: ascender
+ descender: descender
+ fgColor: fgColor
+ bgColor: bgColor
+ depth: depth
+ replaceColor: false.
+ !
Item was added:
+ ----- Method: TTGlyph>>asFormWithScale:ascender:descender:fgColor:bgColor:depth:replaceColor: (in category '*Morphic-Multilingual') -----
+ asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth replaceColor: replaceColorFlag
+
+ ^ self
+ asFormWithScale: scale
+ ascender: ascender
+ descender: descender
+ fgColor: fgColor
+ bgColor: bgColor
+ depth: depth
+ replaceColor: replaceColorFlag
+ lineGlyph: nil
+ lingGlyphWidth: 0
+ emphasis: 0.!
Item was added:
+ ----- Method: TTGlyph>>asFormWithScale:ascender:descender:fgColor:bgColor:depth:replaceColor:lineGlyph:lingGlyphWidth:emphasis: (in category '*Morphic-Multilingual') -----
+ asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth replaceColor: replaceColorFlag lineGlyph: lineGlyph lingGlyphWidth: lWidth emphasis: code
+
+ | form canvas newScale |
+ form := Form extent: (advanceWidth @ (ascender - descender) * scale) rounded depth: depth.
+ form fillColor: bgColor.
+ canvas := BalloonCanvas on: form.
+ canvas aaLevel: 4.
+ canvas transformBy: (MatrixTransform2x3 withScale: scale asPoint * (1 @ -1)).
+ canvas transformBy: (MatrixTransform2x3 withOffset: 0 @ ascender negated).
+ canvas
+ drawGeneralBezierShape: self contours
+ color: fgColor
+ borderWidth: 0
+ borderColor: fgColor.
+ ((code bitAnd: 4) ~= 0 or: [(code bitAnd: 16) ~= 0]) ifTrue: [
+ newScale := (form width + 1) asFloat / lineGlyph calculateWidth asFloat.
+ canvas transformBy: (MatrixTransform2x3 withScale: (newScale / scale)@1.0).
+
+ (code bitAnd: 4) ~= 0 ifTrue: [
+ canvas
+ drawGeneralBezierShape: lineGlyph contours
+ color: fgColor
+ borderWidth: 0
+ borderColor: fgColor.
+ ].
+
+ (code bitAnd: 16) ~= 0 ifTrue: [
+ canvas transformBy: (MatrixTransform2x3 withOffset: 0@(ascender // 2)).
+ canvas
+ drawGeneralBezierShape: lineGlyph contours
+ color: fgColor
+ borderWidth: 0
+ borderColor: fgColor.
+ ].
+ ].
+
+ replaceColorFlag ifTrue: [
+ form replaceColor: bgColor withColor: Color transparent.
+ ].
+ ^ form!
Item was added:
+ BorderedMorph subclass: #TTSampleFontMorph
+ instanceVariableNames: 'font transform smoothing'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-TrueType'!
+
+ !TTSampleFontMorph commentStamp: '<historical>' prior: 0!
+ An example for using TrueType fonts.!
Item was added:
+ ----- Method: TTSampleFontMorph class>>font: (in category 'instance creation') -----
+ font: aTTFontDescription
+ ^self new font: aTTFontDescription!
Item was added:
+ ----- Method: TTSampleFontMorph class>>fontWithoutString: (in category 'connectors') -----
+ fontWithoutString: aTTFontDescription
+ ^self new fontWithoutString: aTTFontDescription!
Item was added:
+ ----- Method: TTSampleFontMorph>>addCustomMenuItems:hand: (in category 'menus') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu addUpdating: #getSmoothingLevel action: #nextSmoothingLevel.!
Item was added:
+ ----- Method: TTSampleFontMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
+ addOptionalHandlesTo: aHalo box: box
+ aHalo addHandleAt: box center color: Color magenta icon: nil on: #mouseDown send: #createSample to: self.!
Item was added:
+ ----- Method: TTSampleFontMorph>>areasRemainingToFill: (in category 'drawing') -----
+ areasRemainingToFill: aRectangle
+ ^ Array with: aRectangle!
Item was added:
+ ----- Method: TTSampleFontMorph>>balloonHelpTextForHandle: (in category 'halos and balloon help') -----
+ balloonHelpTextForHandle: aHandle
+ aHandle eventHandler firstMouseSelector == #createSample
+ ifTrue:[^'Create a sample string'].
+ ^super balloonHelpTextForHandle: aHandle!
Item was added:
+ ----- Method: TTSampleFontMorph>>canDrawBorder: (in category 'testing') -----
+ canDrawBorder: aBorderStyle
+ ^aBorderStyle style == #simple!
Item was added:
+ ----- Method: TTSampleFontMorph>>changed (in category 'updating') -----
+ changed
+ self invalidRect: (self fullBounds expandBy: 1)!
Item was added:
+ ----- Method: TTSampleFontMorph>>computeTransform (in category 'private') -----
+ computeTransform
+ | fullExtent scale |
+ fullExtent := font bounds extent * 16.
+ scale := self extent asFloatPoint / fullExtent asFloatPoint.
+ transform := MatrixTransform2x3 withScale: scale.
+ transform := transform composedWithGlobal: (MatrixTransform2x3 withOffset: self position).
+ ^transform!
Item was added:
+ ----- Method: TTSampleFontMorph>>createSample (in category 'menu') -----
+ createSample
+ self world primaryHand attachMorph: (TTSampleStringMorph font: font)!
Item was added:
+ ----- Method: TTSampleFontMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 1!
Item was added:
+ ----- Method: TTSampleFontMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color black!
Item was added:
+ ----- Method: TTSampleFontMorph>>doesBevels (in category 'accessing') -----
+ doesBevels
+ ^false!
Item was added:
+ ----- Method: TTSampleFontMorph>>drawCharactersOn: (in category 'drawing') -----
+ drawCharactersOn: aCanvas
+ | glyph origin r offset cy m |
+ 0 to: 255 do: [:i |
+ glyph := font at: i.
+ origin := font bounds extent * ((i \\ 16) @ (i // 16)).
+ r := origin extent: font bounds extent.
+ offset := r center - glyph bounds center.
+ cy := glyph bounds center y.
+ m := MatrixTransform2x3 withOffset: 0 at cy.
+ m := m composedWithLocal: (MatrixTransform2x3 withScale: 1 @ -1).
+ m := m composedWithLocal: (MatrixTransform2x3 withOffset: 0 @ cy negated).
+ m := m composedWithGlobal: (MatrixTransform2x3 withOffset: offset).
+ aCanvas asBalloonCanvas preserveStateDuring: [:balloonCanvas |
+ balloonCanvas transformBy: m.
+ balloonCanvas drawGeneralBezierShape: glyph contours
+ color: color
+ borderWidth: 0
+ borderColor: Color black.
+ ].
+ ].!
Item was added:
+ ----- Method: TTSampleFontMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | origin extent offset |
+ (font isNil)
+ ifTrue:[^aCanvas frameRectangle: bounds color: Color black].
+ origin := self position asIntegerPoint.
+ extent := self extent asIntegerPoint.
+ 0 to: 16 do:[:i|
+ offset := (extent x * i // 16) @ (extent y * i // 16).
+ aCanvas line: origin x @ (origin y + offset y)
+ to: (origin x + extent x) @ (origin y + offset y)
+ width: borderWidth color: borderColor.
+ aCanvas line: (origin x + offset x) @ origin y
+ to: (origin x + offset x) @ (origin y + extent y)
+ width: borderWidth color: borderColor.
+ ].
+ aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
+ balloonCanvas transformBy: self transform.
+ balloonCanvas aaLevel: self smoothing.
+ self drawCharactersOn: balloonCanvas.
+ ].!
Item was added:
+ ----- Method: TTSampleFontMorph>>extent: (in category 'geometry') -----
+ extent: extentPoint
+ super extent: extentPoint.
+ transform := nil.!
Item was added:
+ ----- Method: TTSampleFontMorph>>font (in category 'accessing') -----
+ font
+ ^ font!
Item was added:
+ ----- Method: TTSampleFontMorph>>font: (in category 'accessing') -----
+ font: aTTFontDescription
+ | morph |
+ font := aTTFontDescription.
+ morph := (TTSampleStringMorph font: font).
+ morph extent: morph extent * 2.
+ morph color: Color magenta.
+ self addMorphCentered: morph.
+ morph position: morph position x @ (self bounds bottom + 10).
+ self privateFullMoveBy: self fullBounds origin negated.!
Item was added:
+ ----- Method: TTSampleFontMorph>>fontWithoutString: (in category 'connectors') -----
+ fontWithoutString: aTTFontDescription
+ font := aTTFontDescription.
+ !
Item was added:
+ ----- Method: TTSampleFontMorph>>getSmoothingLevel (in category 'menu') -----
+ getSmoothingLevel
+ "Menu support"
+ smoothing = 1
+ ifTrue: [^ 'turn on smoothing' translated].
+ smoothing = 2
+ ifTrue: [^ 'more smoothing' translated].
+ smoothing = 4
+ ifTrue: [^ 'turn off smoothing' translated]!
Item was added:
+ ----- Method: TTSampleFontMorph>>glyphAt: (in category 'connectors') -----
+ glyphAt: position
+ ^font at: (self glyphIndexAt: position).!
Item was added:
+ ----- Method: TTSampleFontMorph>>glyphIndexAt: (in category 'connectors') -----
+ glyphIndexAt: position
+ | offset |
+ offset := (position adhereTo: (bounds insetBy: 1)) - bounds origin.
+ offset := (offset asFloatPoint / bounds extent) * 16.
+ offset := offset truncated.
+ ^offset y * 16 + offset x!
Item was added:
+ ----- Method: TTSampleFontMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ smoothing := 4.
+ self extent: 300 @ 300!
Item was added:
+ ----- Method: TTSampleFontMorph>>newTransformationMorph (in category 'rotate scale and flex') -----
+ newTransformationMorph
+ ^MatrixTransformMorph new!
Item was added:
+ ----- Method: TTSampleFontMorph>>nextSmoothingLevel (in category 'menu') -----
+ nextSmoothingLevel
+ smoothing = 1
+ ifTrue: [smoothing := 2]
+ ifFalse: [smoothing = 2
+ ifTrue: [smoothing := 4]
+ ifFalse: [smoothing = 4
+ ifTrue: [smoothing := 1]]].
+ self changed!
Item was added:
+ ----- Method: TTSampleFontMorph>>open (in category 'initialize') -----
+ open
+ ^self openInWorld!
Item was added:
+ ----- Method: TTSampleFontMorph>>openInWorld (in category 'initialization') -----
+ openInWorld
+ HandMorph attach: self!
Item was added:
+ ----- Method: TTSampleFontMorph>>position: (in category 'geometry') -----
+ position: pos
+ super position: pos.
+ transform := nil.!
Item was added:
+ ----- Method: TTSampleFontMorph>>printOn: (in category 'connectors') -----
+ printOn: aStream
+ aStream nextPutAll: 'TTSampleFont(';
+ nextPutAll: font familyName;
+ nextPut: $)!
Item was added:
+ ----- Method: TTSampleFontMorph>>privateMoveBy: (in category 'private') -----
+ privateMoveBy: delta
+ super privateMoveBy: delta.
+ transform := nil.!
Item was added:
+ ----- Method: TTSampleFontMorph>>selectGlyph (in category 'connectors') -----
+ selectGlyph
+ | retval done |
+ "Modal glyph selector"
+ done := false.
+ self on: #mouseDown send: #selectGlyphBlock:event:from: to: self withValue: [ :glyph | retval := glyph. done := true. ].
+ self on: #keyStroke send: #value to: [ done := true ].
+ [ done ] whileFalse: [ self world doOneCycle ].
+ self on: #mouseDown send: nil to: nil.
+ self on: #keyStroke send: nil to: nil.
+ ^retval!
Item was added:
+ ----- Method: TTSampleFontMorph>>selectGlyphAndSendTo: (in category 'connectors') -----
+ selectGlyphAndSendTo: aBlock
+ self on: #mouseDown send: #selectGlyphBlock:event:from: to: self withValue: aBlock.!
Item was added:
+ ----- Method: TTSampleFontMorph>>selectGlyphBlock:event:from: (in category 'connectors') -----
+ selectGlyphBlock: aBlock event: evt from: me
+ aBlock value: (self glyphAt: evt position).
+ !
Item was added:
+ ----- Method: TTSampleFontMorph>>smoothing (in category 'accessing') -----
+ smoothing
+ ^ smoothing!
Item was added:
+ ----- Method: TTSampleFontMorph>>smoothing: (in category 'accessing') -----
+ smoothing: aNumber
+ smoothing := aNumber.
+ self changed!
Item was added:
+ ----- Method: TTSampleFontMorph>>transform (in category 'accessing') -----
+ transform
+ ^transform ifNil:[self computeTransform].!
Item was added:
+ ----- Method: TTSampleFontMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If fields were weakly copied, fix them here. If they were in the
+ tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ font := deepCopier references at: font ifAbsent: [font]!
Item was added:
+ ----- Method: TTSampleFontMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all,
+ but shared. Warning!!!! Every instance variable defined in this class
+ must be handled. We must also implement veryDeepFixupWith:.
+ See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ "font := font"
+ transform := transform veryDeepCopyWith: deepCopier.
+ smoothing := smoothing veryDeepCopyWith: deepCopier!
Item was added:
+ TTSampleFontMorph subclass: #TTSampleStringMorph
+ instanceVariableNames: 'string ttBounds'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-TrueType'!
+
+ !TTSampleStringMorph commentStamp: '<historical>' prior: 0!
+ I allow the display of a string in a TrueType font as a stand-alone morph.
+
+ Morph's color changes the inside of the characters.
+ Morph's borderColor changes the outline.
+
+ Many free fonts are stored at www.FontGuy.com.
+ Use a normal web browser (not our Scamper) and go there.
+ Choose 'categories' and browse to a font you like.
+ Hold the mouse down on the example text in that font.
+ When the menu comes up, choose "Copy this link location".
+ Come back into Squeak, choose "load font from web..."
+ from my menu, and paste in the url.!
Item was added:
+ ----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ ^ self partName: 'TrueType banner'
+ categories: #('Demo')
+ documentation: 'A short text in a beautiful font. Use the resize handle to change size.'!
Item was added:
+ ----- Method: TTSampleStringMorph>>addCustomMenuItems:hand: (in category 'menus') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu add: 'edit contents...' translated action: #edit.
+ aCustomMenu add: 'how to find more fonts...' translated action: #howTo.
+ aCustomMenu add: 'load font from web...' translated action: #loadFromURL.!
Item was added:
+ ----- Method: TTSampleStringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
+ addOptionalHandlesTo: aHalo box: box!
Item was added:
+ ----- Method: TTSampleStringMorph>>computeTransform (in category 'private') -----
+ computeTransform
+ | cy |
+ cy := bounds origin y + bounds corner y * 0.5.
+ transform := MatrixTransform2x3
+ transformFromLocal: (ttBounds insetBy: borderWidth negated)
+ toGlobal: bounds.
+ transform := transform composedWithGlobal:(MatrixTransform2x3 withOffset: 0 @ cy negated).
+ transform := transform composedWithGlobal:(MatrixTransform2x3 withScale: 1.0 @ -1.0).
+ transform := transform composedWithGlobal:(MatrixTransform2x3 withOffset: 0 @ cy).
+ ^transform!
Item was added:
+ ----- Method: TTSampleStringMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+ "^ super containsPoint: aPoint"
+
+ "so much faster..."
+
+ | picker |
+ (self bounds containsPoint: aPoint) ifFalse: [^false].
+ picker := BalloonCanvas on: (Form extent: 1 @ 1 depth: 32).
+ picker transformBy: (MatrixTransform2x3 withOffset: aPoint negated).
+ self drawOn: picker.
+ ^(picker form bits first) ~= 0!
Item was added:
+ ----- Method: TTSampleStringMorph>>defaultBorderWidth (in category 'initialization') -----
+ defaultBorderWidth
+ "answer the default border width for the receiver"
+ ^ 0!
Item was added:
+ ----- Method: TTSampleStringMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ {Color magenta. Color yellow. Color orange. Color lightGray} atRandom!
Item was added:
+ ----- Method: TTSampleStringMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ | xStart |
+ (font isNil or:[string isNil or:[string isEmpty]])
+ ifTrue:[^aCanvas frameRectangle: bounds color: Color black].
+ xStart := 0.
+ aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
+ balloonCanvas transformBy: self transform.
+ balloonCanvas aaLevel: self smoothing.
+ string do:[:char| | glyph |
+ glyph := font at: char.
+ balloonCanvas preserveStateDuring:[:subCanvas|
+ subCanvas transformBy: (MatrixTransform2x3 withOffset: xStart at 0).
+ subCanvas
+ drawGeneralBezierShape: glyph contours
+ color: color
+ borderWidth: borderWidth
+ borderColor: borderColor].
+ xStart := xStart + glyph advanceWidth.
+ ].
+ ].!
Item was added:
+ ----- Method: TTSampleStringMorph>>edit (in category 'menus') -----
+ edit
+ "Allow the user to change the text in a crude way"
+
+ | str |
+ str := FillInTheBlankMorph request: 'Type in new text for this TrueType displayer.'
+ initialAnswer: 'some text'.
+ str isEmpty ifTrue: [^ self].
+ self string: str.
+ !
Item was added:
+ ----- Method: TTSampleStringMorph>>font: (in category 'accessing') -----
+ font: aTTFontDescription
+ font := aTTFontDescription.
+ string ifNil: [self string: aTTFontDescription fullName]
+ ifNotNil: [self initializeString].!
Item was added:
+ ----- Method: TTSampleStringMorph>>howTo (in category 'menus') -----
+ howTo
+
+ self inform: 'Many free fonts are stored at www.FontGuy.com.
+ Use a normal web browser (not our Scamper) and go there.
+ Choose ''categories'' and browse to a font you like.
+ Hold the mouse down on the example text in that font.
+ When the menu comes up, choose "Copy this link location".
+ Come back into Squeak, choose "load font from web..."
+ from this menu, and paste in the url.'!
Item was added:
+ ----- Method: TTSampleStringMorph>>initializeString (in category 'initialize') -----
+ initializeString
+ | xStart char glyph |
+ (font isNil or: [string isNil]) ifTrue: [^ self].
+ xStart := 0.
+ ttBounds := 0 at 0 corner: 0 at 0.
+ 1 to: string size do:
+ [:i |
+ char := string at: i.
+ glyph := font at: char.
+ ttBounds := ttBounds quickMerge: (glyph bounds translateBy: xStart at 0).
+ xStart := xStart + glyph advanceWidth.
+ ].
+ self extent: ttBounds extent // 40.
+ borderWidth := ttBounds height // 40!
Item was added:
+ ----- Method: TTSampleStringMorph>>initializeToStandAlone (in category 'parts bin') -----
+ initializeToStandAlone
+ "Make me into an example"
+
+ | dd |
+ dd := TTFontDescription default.
+ dd ifNil: [^ RectangleMorph initializeToStandAlone]. "not available"
+
+ super initializeToStandAlone.
+ self font: dd; color: (TranslucentColor r: 1.0 g: 0.097 b: 1.0 alpha: 0.6).
+ self string: 'TrueType fonts are beautiful'.
+ !
Item was added:
+ ----- Method: TTSampleStringMorph>>loadFromURL (in category 'menus') -----
+ loadFromURL
+ "Allow the user to change the text in a crude way"
+
+ | url |
+ url := FillInTheBlankMorph request: ' Type in the url for a TrueType font on the web. '
+ initialAnswer: 'http://www.fontguy.com/download.asp?fontid=1494'.
+ url isEmpty ifTrue: [^ self].
+ self loadFromURL: url.
+ !
Item was added:
+ ----- Method: TTSampleStringMorph>>loadFromURL: (in category 'menus') -----
+ loadFromURL: urlString
+ "Fetch the file, unarchive, unzip, and use as my font."
+
+ | rawStrm |
+ rawStrm := HTTPSocket httpGet: urlString. "Later use an HttpURL?"
+ self font: (TTFontReader readFrom: rawStrm asUnZippedStream).
+ !
Item was added:
+ ----- Method: TTSampleStringMorph>>printOn: (in category 'printing') -----
+ printOn: aStream
+ aStream nextPutAll: 'TTSampleString(';
+ nextPutAll: font familyName;
+ nextPut: $)!
Item was added:
+ ----- Method: TTSampleStringMorph>>string (in category 'accessing') -----
+ string
+ ^ string!
Item was added:
+ ----- Method: TTSampleStringMorph>>string: (in category 'accessing') -----
+ string: aString
+ string := aString.
+ self initializeString.!
Item was added:
+ LayoutPolicy subclass: #TableLayout
+ instanceVariableNames: 'properties minExtentCache'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Layouts'!
+
+ !TableLayout commentStamp: '<historical>' prior: 0!
+ The layout process:
+ For computing the new layout for the children of any morph, we start with an initial rectangle which is provided as a reference.
+
+ Step 1: The first step of layout computation is to compute the minimum extent each of our children can have. The minimum extent is mapped through both the local layout frame of the morph (for relative positioning) and the global layout frame (for insets, such as cursor indication) to obtain the minimal size required for each cell.
+
+ Step 2: Based on the cell sizes, the number of cells we can put into each row and column is computed. For equal spacing, the maximum size of the cells is taken into account here.
+
+ Step 3: Based on the row/column sizes, we compute the extra space which should be added to each row/column. For
+ #leftFlush/#topFlush - we add all extra space add the end
+ #rightFlush/#bottomFlush - we add all extra space at the start
+ #centering - we add 1/2 of the extra space at start and end
+ #justified - we distribute the space evenly between the morphs
+ [NOTE: If any #spaceFill morphs are encountered during this step, #justified is implied and the space is exclusively and equally distributed between those #spaceFill morphs. This is for backward compatibility and should *never* be necessary in the new regime].
+
+ Step 4: The morphs are placed in the computed cells and the extra space is distributed as necessary. Placing the submorphs is done by mapping through the global and the local layout frame as requested.
+
+ Start point:
+ => bounds: new rectangle for the morph.
+
+ Compute basic arrangement of morphs:
+ => For each submorph compute minExtent
+ - if global layout frame inset in global layout frame
+ - if local layout frame inset in local layout frame
+ => Compute number of morphs per, width and height of row/column
+ - if equal spacing based on max size
+ => Compute extra space per row/column
+ - if centering = #justified; distribute space equally
+ - if centering #leftFlush/#topFlush (-1) add start extra
+ - if centering #rightFlush/#bottomFlush (1) add end extra
+ - if centering #centered add 1/2 extra to start/end
+ <extra space must be float and rounded accordingly!!>
+ => Place morphs in appropriate cells
+ - if global layout frame inset in global layout frame
+ - if local layout frame inset in local layout frame
+ <will likely cause #layoutChanged by submorphs>
+
+ Distribute morphs in row/column:
+
+ => Compute the max length of each row/column
+ !
Item was added:
+ ----- Method: TableLayout>>computeCellArrangement:in:horizontal:target: (in category 'layout') -----
+ computeCellArrangement: cellHolder in: newBounds horizontal: aBool target: aMorph
+ "Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level.
+ Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row."
+
+ | cells wrap spacing output maxExtent n sum index max cell first last w cellMax maxCell hFill vFill inset |
+ maxCell := cellHolder key.
+ cells := cellHolder value.
+ properties wrapDirection == #none
+ ifTrue: [wrap := SmallInteger maxVal]
+ ifFalse:
+ [wrap := aBool ifTrue: [newBounds width] ifFalse: [newBounds height].
+ wrap := wrap max: (maxCell x)].
+ spacing := properties cellSpacing.
+ (spacing == #globalRect or: [spacing = #globalSquare])
+ ifTrue:
+ ["Globally equal spacing is a very special case here, so get out fast and easy"
+
+ ^self
+ computeGlobalCellArrangement: cells
+ in: newBounds
+ horizontal: aBool
+ wrap: wrap
+ spacing: spacing].
+ output := WriteStream on: Array new.
+ inset := properties cellInset asPoint.
+ aBool ifFalse: [inset := inset transposed].
+ first := last := nil.
+ maxExtent := 0 @ 0.
+ sum := 0.
+ index := 1.
+ n := 0.
+ hFill := vFill := false.
+ [index <= cells size] whileTrue:
+ [w := sum.
+ cell := cells at: index.
+ cellMax := maxExtent max: cell cellSize. "e.g., minSize"
+ sum := (spacing == #localRect or: [spacing == #localSquare])
+ ifTrue:
+ ["Recompute entire size of current row"
+
+ max := spacing == #localSquare
+ ifTrue: [cellMax x max: cellMax y]
+ ifFalse: [cellMax x].
+ (n + 1) * max]
+ ifFalse: [sum + cell cellSize x].
+ (sum + (n * inset x) > wrap and: [first notNil])
+ ifTrue:
+ ["It doesn't fit and we're not starting a new line"
+
+ (spacing == #localSquare or: [spacing == #localRect])
+ ifTrue:
+ [spacing == #localSquare
+ ifTrue: [maxExtent := (maxExtent x max: maxExtent y) asPoint].
+ first do: [:c | c cellSize: maxExtent]].
+ w := w + ((n - 1) * inset x).
+ "redistribute extra space"
+ first nextCell
+ ifNotNil: [first nextCell do: [:c | c addExtraSpace: inset x @ 0]].
+ last := LayoutCell new.
+ last cellSize: w @ maxExtent y.
+ last hSpaceFill: hFill.
+ last vSpaceFill: vFill.
+ last nextCell: first.
+ output position = 0 ifFalse: [last addExtraSpace: 0 @ inset y].
+ output nextPut: last.
+ first := nil.
+ maxExtent := 0 @ 0.
+ sum := 0.
+ n := 0.
+ hFill := vFill := false]
+ ifFalse:
+ ["It did fit; use next item from input"
+
+ first ifNil: [first := last := cell]
+ ifNotNil:
+ [last nextCell: cell.
+ last := cell].
+ index := index + 1.
+ n := n + 1.
+ maxExtent := cellMax.
+ hFill := hFill or: [cell hSpaceFill].
+ vFill := vFill or: [cell vSpaceFill]]].
+ first ifNotNil:
+ [last := LayoutCell new.
+ sum := sum + ((n - 1) * inset x).
+ first nextCell
+ ifNotNil: [first nextCell do: [:c | c addExtraSpace: inset x @ 0]].
+ last cellSize: sum @ maxExtent y.
+ last hSpaceFill: hFill.
+ last vSpaceFill: vFill.
+ last nextCell: first.
+ output position = 0 ifFalse: [last addExtraSpace: 0 @ inset y].
+ output nextPut: last].
+ output := output contents.
+ properties listSpacing == #equal
+ ifTrue:
+ ["Make all the heights equal"
+
+ max := output inject: 0 into: [:size :c | size max: c cellSize y].
+ output do: [:c | c cellSize: c cellSize x @ max]].
+ ^output!
Item was added:
+ ----- Method: TableLayout>>computeCellSizes:in:horizontal: (in category 'layout') -----
+ computeCellSizes: aMorph in: newBounds horizontal: aBool
+ "Step 1: Compute the minimum extent for all the children of aMorph"
+ | cells block minSize maxSize maxCell |
+ cells := WriteStream on: (Array new: aMorph submorphCount).
+ minSize := properties minCellSize asPoint.
+ maxSize := properties maxCellSize asPoint.
+ aBool ifTrue:[
+ minSize := minSize transposed.
+ maxSize := maxSize transposed].
+ maxCell := 0 at 0.
+ block := [:m| | size cell |
+ m disableTableLayout ifFalse:[
+ size := m minExtent asIntegerPoint.
+ cell := LayoutCell new target: m.
+ aBool ifTrue:[
+ cell hSpaceFill: m hResizing == #spaceFill.
+ cell vSpaceFill: m vResizing == #spaceFill.
+ ] ifFalse:[
+ cell hSpaceFill: m vResizing == #spaceFill.
+ cell vSpaceFill: m hResizing == #spaceFill.
+ size := size transposed.
+ ].
+ size := (size min: maxSize) max: minSize.
+ cell cellSize: size.
+ maxCell := maxCell max: size.
+ cells nextPut: cell]].
+ properties reverseTableCells
+ ifTrue:[aMorph submorphsReverseDo: block]
+ ifFalse:[aMorph submorphsDo: block].
+ ^maxCell -> cells contents!
Item was added:
+ ----- Method: TableLayout>>computeExtraSpacing:in:horizontal:target: (in category 'layout') -----
+ computeExtraSpacing: arrangement in: newBounds horizontal: aBool target: aMorph
+ "Compute the required extra spacing for laying out the cells"
+
+ "match newBounds extent with arrangement's orientation"
+
+ | extent extra centering n extraPerCell cell last hFill vFill max amount allow |
+ extent := newBounds extent.
+ aBool ifFalse: [extent := extent transposed].
+
+ "figure out if we have any horizontal or vertical space fillers"
+ hFill := vFill := false.
+ max := 0 @ 0.
+ arrangement do:
+ [:c |
+ max := (max x max: c cellSize x) @ (max y + c cellSize y).
+ max := max max: c cellSize.
+ hFill := hFill or: [c hSpaceFill].
+ vFill := vFill or: [c vSpaceFill]].
+
+ "Take client's shrink wrap constraints into account.
+ Note: these are only honored when there are no #spaceFill children,
+ or when #rubberBandCells is set."
+ allow := properties rubberBandCells not.
+ aMorph hResizing == #shrinkWrap
+ ifTrue:
+ [aBool
+ ifTrue: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]]
+ ifFalse: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]].
+ aMorph vResizing == #shrinkWrap
+ ifTrue:
+ [aBool
+ ifFalse: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]]
+ ifTrue: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]].
+
+ "Now compute the extra v space"
+ extra := extent y
+ - (arrangement inject: 0 into: [:sum :c | sum + c cellSize y]).
+ extra > 0
+ ifTrue:
+ ["Check if we have any #spaceFillers"
+
+ vFill
+ ifTrue:
+ ["use only #spaceFillers"
+
+ n := arrangement inject: 0
+ into: [:sum :c | c vSpaceFill ifTrue: [sum + 1] ifFalse: [sum]].
+ n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat].
+ extra := last := 0.
+ arrangement do:
+ [:c |
+ c vSpaceFill
+ ifTrue:
+ [extra := (last := extra) + extraPerCell.
+ amount := 0 @ (extra truncated - last truncated).
+ c do: [:cc | cc cellSize: cc cellSize + amount]]]]
+ ifFalse:
+ ["no #spaceFillers; distribute regularly"
+
+ centering := properties wrapCentering.
+ "centering == #topLeft ifTrue:[]." "add all extra space to the last cell; e.g., do nothing"
+ centering == #bottomRight
+ ifTrue:
+ ["add all extra space to the first cell"
+
+ arrangement first addExtraSpace: 0 @ extra].
+ centering == #center
+ ifTrue:
+ ["add 1/2 extra space to the first and last cell"
+
+ arrangement first addExtraSpace: 0 @ (extra // 2)].
+ centering == #justified
+ ifTrue:
+ ["add extra space equally distributed to each cell"
+
+ n := arrangement size - 1 max: 1.
+ extraPerCell := extra asFloat / n asFloat.
+ extra := last := 0.
+ arrangement do:
+ [:c |
+ c addExtraSpace: 0 @ (extra truncated - last truncated).
+ extra := (last := extra) + extraPerCell]]]].
+
+ "Now compute the extra space for the primary direction"
+ centering := properties listCentering.
+ 1 to: arrangement size
+ do:
+ [:i |
+ cell := arrangement at: i.
+ extra := extent x - cell cellSize x.
+ extra > 0
+ ifTrue:
+ ["Check if we have any #spaceFillers"
+ cell := cell nextCell.
+ cell hSpaceFill
+ ifTrue:
+ ["use only #spaceFillers"
+
+
+ n := cell inject: 0
+ into: [:sum :c | c hSpaceFill ifTrue: [sum + c target spaceFillWeight] ifFalse: [sum]].
+ n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat].
+ extra := last := 0.
+ cell do:
+ [:c |
+ c hSpaceFill
+ ifTrue:
+ [extra := (last := extra) + (extraPerCell * c target spaceFillWeight).
+ amount := extra truncated - last truncated.
+ c cellSize: c cellSize + (amount @ 0)]]]
+ ifFalse:
+ ["no #spaceFiller; distribute regularly"
+
+
+ "centering == #topLeft ifTrue:[]" "add all extra space to the last cell; e.g., do nothing"
+ centering == #bottomRight
+ ifTrue:
+ ["add all extra space to the first cell"
+
+ cell addExtraSpace: extra @ 0].
+ centering == #center
+ ifTrue:
+ ["add 1/2 extra space to the first and last cell"
+
+ cell addExtraSpace: (extra // 2) @ 0].
+ centering == #justified
+ ifTrue:
+ ["add extra space equally distributed to each cell"
+
+ n := cell size - 1 max: 1.
+ extraPerCell := extra asFloat / n asFloat.
+ extra := last := 0.
+ cell do:
+ [:c |
+ c addExtraSpace: (extra truncated - last truncated) @ 0.
+ extra := (last := extra) + extraPerCell]]]]]!
Item was added:
+ ----- Method: TableLayout>>computeGlobalCellArrangement:in:horizontal:wrap:spacing: (in category 'layout') -----
+ computeGlobalCellArrangement: cells in: newBounds horizontal: aBool wrap: wrap spacing: spacing
+ "Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level.
+ Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row."
+ | output maxExtent n cell first last hFill vFill |
+ output := (WriteStream on: Array new).
+ first := last := nil.
+ maxExtent := cells inject: 0 at 0 into:[:size :c| size max: c cellSize "e.g., minSize"].
+ spacing == #globalSquare ifTrue:[maxExtent := (maxExtent x max: maxExtent y) asPoint].
+ n := (wrap // maxExtent x) max: 1.
+ hFill := vFill := false.
+ 1 to: cells size do:[:i|
+ cell := cells at: i.
+ hFill := hFill or:[cell hSpaceFill].
+ vFill := vFill or:[cell vSpaceFill].
+ cell cellSize: maxExtent.
+ first ifNil:[first := last := cell] ifNotNil:[last nextCell: cell. last := cell].
+ (i \\ n) = 0 ifTrue:[
+ last := LayoutCell new.
+ last cellSize: (maxExtent x * n) @ (maxExtent y).
+ last hSpaceFill: hFill.
+ last vSpaceFill: vFill.
+ hFill := vFill := false.
+ last nextCell: first.
+ output nextPut: last.
+ first := nil]].
+ first ifNotNil:[
+ last := LayoutCell new.
+ last cellSize: (maxExtent x * n) @ (maxExtent y). self flag: #arNote."@@@: n is not correct!!"
+ last nextCell: first.
+ output nextPut: last].
+ ^output contents
+ !
Item was added:
+ ----- Method: TableLayout>>flushLayoutCache (in category 'layout') -----
+ flushLayoutCache
+ "Flush any cached information associated with the receiver"
+ minExtentCache := nil.!
Item was added:
+ ----- Method: TableLayout>>indexForInserting:at:in: (in category 'utilities') -----
+ indexForInserting: aMorph at: aPoint in: owner
+ "Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion."
+
+ | horizontal morphList index |
+ owner hasSubmorphs ifFalse: [^1].
+ aMorph disableTableLayout ifTrue: [^1].
+ horizontal := (owner listDirection == #topToBottom
+ or: [owner listDirection == #bottomToTop]) not .
+ morphList := owner submorphs.
+ owner reverseTableCells ifTrue: [morphList := morphList reversed].
+ index := self
+ indexForInserting: aPoint
+ inList: morphList
+ horizontal: horizontal
+ target: owner.
+ owner reverseTableCells ifTrue: [index := morphList size - index + 2].
+ ^index ifNil: [1]!
Item was added:
+ ----- Method: TableLayout>>indexForInserting:inList:horizontal:target: (in category 'utilities') -----
+ indexForInserting: aPoint inList: morphList horizontal: aBool target: aMorph
+ | cmp1 cmp2 cmp3 noWrap |
+ properties := aMorph layoutProperties.
+ noWrap := properties wrapDirection == #none.
+ aBool
+ ifTrue:
+ ["horizontal"
+
+ properties listDirection == #rightToLeft
+ ifTrue: [cmp1 := [:rect | aPoint x > rect left]]
+ ifFalse: [cmp1 := [:rect | aPoint x < rect right]].
+ properties wrapDirection == #bottomToTop
+ ifTrue:
+ [cmp2 := [:rect | aPoint y > rect top].
+ cmp3 := [:rect | aPoint y > rect bottom]]
+ ifFalse:
+ [cmp2 := [:rect | aPoint y < rect bottom].
+ cmp3 := [:rect | aPoint y < rect top]]]
+ ifFalse:
+ ["vertical"
+
+ properties listDirection == #bottomToTop
+ ifTrue: [cmp1 := [:rect | aPoint y > rect top]]
+ ifFalse: [cmp1 := [:rect | aPoint y < rect bottom]].
+ properties wrapDirection == #rightToLeft
+ ifTrue:
+ [cmp2 := [:rect | aPoint x > rect left].
+ cmp3 := [:rect | aPoint x > rect right]]
+ ifFalse:
+ [cmp2 := [:rect | aPoint x < rect right].
+ cmp3 := [:rect | aPoint x < rect left]]].
+ morphList keysAndValuesDo:
+ [:index :m | | box |
+ self flag: #arNote. "it is not quite clear if we can really use #fullBounds here..."
+ box := m fullBounds.
+ noWrap
+ ifTrue:
+ ["Only in one direction"
+
+ (cmp1 value: box) ifTrue: [^index]]
+ ifFalse:
+ ["Check for inserting before current row"
+
+ (cmp3 value: box) ifTrue: [^index].
+ "Check for inserting before current cell"
+ ((cmp1 value: box) and: [cmp2 value: box]) ifTrue: [^index]]].
+ ^morphList size + 1!
Item was added:
+ ----- Method: TableLayout>>isTableLayout (in category 'testing') -----
+ isTableLayout
+ ^true!
Item was added:
+ ----- Method: TableLayout>>layout:in: (in category 'layout') -----
+ layout: aMorph in: box
+ "Compute the layout for the given morph based on the new bounds"
+
+ | cells arrangement horizontal newBounds |
+ aMorph hasSubmorphs ifFalse: [^self].
+ properties := aMorph assureTableProperties.
+ newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint.
+ (properties wrapDirection == #none and: [properties cellSpacing == #none])
+ ifTrue:
+ ["get into the fast lane"
+
+ properties listCentering == #justified
+ ifFalse:
+ ["can't deal with that"
+
+ properties listDirection == #leftToRight
+ ifTrue: [^self layoutLeftToRight: aMorph in: newBounds].
+ properties listDirection == #topToBottom
+ ifTrue: [^self layoutTopToBottom: aMorph in: newBounds]]].
+ horizontal := (properties listDirection == #topToBottom
+ or: [properties listDirection == #bottomToTop]) not.
+ "Step 1: Compute the minimum extent for all the children of aMorph"
+ cells := self
+ computeCellSizes: aMorph
+ in: (0 @ 0 corner: newBounds extent)
+ horizontal: horizontal.
+ "Step 2: Compute the arrangement of the cells for each row and column"
+ arrangement := self
+ computeCellArrangement: cells
+ in: newBounds
+ horizontal: horizontal
+ target: aMorph.
+ "Step 3: Compute the extra spacing for each cell"
+ self
+ computeExtraSpacing: arrangement
+ in: newBounds
+ horizontal: horizontal
+ target: aMorph.
+ "Step 4: Place the children within the cells accordingly"
+ self
+ placeCells: arrangement
+ in: newBounds
+ horizontal: horizontal
+ target: aMorph!
Item was added:
+ ----- Method: TableLayout>>layoutLeftToRight:in: (in category 'optimized') -----
+ layoutLeftToRight: aMorph in: newBounds
+ "An optimized left-to-right list layout"
+
+ | inset extent block posX posY centering extraPerCell amount minX minY maxX maxY n width extra last cell size height sum vFill first |
+ size := properties minCellSize asPoint.
+ minX := size x.
+ minY := size y.
+ size := properties maxCellSize asPoint.
+ maxX := size x.
+ maxY := size y.
+ inset := properties cellInset asPoint x.
+ extent := newBounds extent.
+ n := 0.
+ vFill := false.
+ sum := 0.
+ width := height := 0.
+ first := last := nil.
+ block :=
+ [:m | | sizeX props sizeY |
+ props := m layoutProperties ifNil: [m].
+ props disableTableLayout
+ ifFalse:
+ [n := n + 1.
+ cell := LayoutCell new target: m.
+ props hResizing == #spaceFill
+ ifTrue:
+ [cell hSpaceFill: true.
+ extra := m spaceFillWeight.
+ cell extraSpace: extra.
+ sum := sum + extra]
+ ifFalse: [cell hSpaceFill: false].
+ props vResizing == #spaceFill ifTrue: [vFill := true].
+ size := m minExtent.
+ size := m minExtent.
+ sizeX := size x.
+ sizeY := size y.
+ sizeX < minX ifTrue: [sizeX := minX] ifFalse: [sizeX := sizeX min: maxX].
+ sizeY < minY ifTrue: [sizeY := minY] ifFalse: [sizeY := sizeY min: maxY].
+ cell cellSize: sizeX.
+ last ifNil: [first := cell] ifNotNil: [last nextCell: cell].
+ last := cell.
+ width := width + sizeX.
+ sizeY > height ifTrue: [height := sizeY]]].
+ properties reverseTableCells
+ ifTrue: [aMorph submorphsReverseDo: block]
+ ifFalse: [aMorph submorphsDo: block].
+ n > 1 ifTrue: [width := width + ((n - 1) * inset)].
+ (properties hResizing == #shrinkWrap
+ and: [properties rubberBandCells or: [sum isZero]])
+ ifTrue: [extent := width @ (extent y max: height)].
+ (properties vResizing == #shrinkWrap
+ and: [properties rubberBandCells or: [vFill not]])
+ ifTrue: [extent := (extent x max: width) @ height].
+ posX := newBounds left.
+ posY := newBounds top.
+
+ "Compute extra vertical space"
+ extra := extent y - height.
+ extra := extra max: 0.
+ extra > 0
+ ifTrue:
+ [vFill
+ ifTrue: [height := extent y]
+ ifFalse:
+ [centering := properties wrapCentering.
+ centering == #bottomRight ifTrue: [posY := posY + extra].
+ centering == #center ifTrue: [posY := posY + (extra // 2)]]].
+
+
+ "Compute extra horizontal space"
+ extra := extent x - width.
+ extra := extra max: 0.
+ extraPerCell := 0.
+ extra > 0
+ ifTrue:
+ [sum isZero
+ ifTrue:
+ ["extra space but no #spaceFillers"
+
+ centering := properties listCentering.
+ centering == #bottomRight ifTrue: [posX := posX + extra].
+ centering == #center ifTrue: [posX := posX + (extra // 2)]]
+ ifFalse: [extraPerCell := extra asFloat / sum asFloat]].
+ n := 0.
+ extra := last := 0.
+ cell := first.
+ [cell isNil] whileFalse:
+ [n := n + 1.
+ width := cell cellSize.
+ (extraPerCell > 0 and: [cell hSpaceFill])
+ ifTrue:
+ [extra := (last := extra) + (extraPerCell * cell extraSpace).
+ amount := extra truncated - last truncated.
+ width := width + amount].
+ cell target layoutInBounds: (posX @ posY extent: width @ height).
+ posX := posX + width + inset.
+ cell := cell nextCell]!
Item was added:
+ ----- Method: TableLayout>>layoutTopToBottom:in: (in category 'optimized') -----
+ layoutTopToBottom: aMorph in: newBounds
+ "An optimized top-to-bottom list layout"
+
+ | inset extent block posX posY centering extraPerCell amount minX minY maxX maxY n height extra last cell size width sum vFill first |
+ size := properties minCellSize asPoint.
+ minX := size x.
+ minY := size y.
+ size := properties maxCellSize asPoint.
+ maxX := size x.
+ maxY := size y.
+ inset := properties cellInset asPoint y.
+ extent := newBounds extent.
+ n := 0.
+ vFill := false.
+ sum := 0.
+ width := height := 0.
+ first := last := nil.
+ block :=
+ [:m | | sizeY sizeX props |
+ props := m layoutProperties ifNil: [m].
+ props disableTableLayout
+ ifFalse:
+ [n := n + 1.
+ cell := LayoutCell new target: m.
+ props vResizing == #spaceFill
+ ifTrue:
+ [cell vSpaceFill: true.
+ extra := m spaceFillWeight.
+ cell extraSpace: extra.
+ sum := sum + extra]
+ ifFalse: [cell vSpaceFill: false].
+ props hResizing == #spaceFill ifTrue: [vFill := true].
+ size := m minExtent.
+ sizeX := size x.
+ sizeY := size y.
+ sizeX < minX ifTrue: [sizeX := minX] ifFalse: [sizeX := sizeX min: maxX].
+ sizeY < minY ifTrue: [sizeY := minY] ifFalse: [sizeY := sizeY min: maxY].
+ cell cellSize: sizeY.
+ first ifNil: [first := cell] ifNotNil: [last nextCell: cell].
+ last := cell.
+ height := height + sizeY.
+ sizeX > width ifTrue: [width := sizeX]]].
+ properties reverseTableCells
+ ifTrue: [aMorph submorphsReverseDo: block]
+ ifFalse: [aMorph submorphsDo: block].
+ n > 1 ifTrue: [height := height + ((n - 1) * inset)].
+ (properties vResizing == #shrinkWrap
+ and: [properties rubberBandCells or: [sum isZero]])
+ ifTrue: [extent := (extent x max: width) @ height].
+ (properties hResizing == #shrinkWrap
+ and: [properties rubberBandCells or: [vFill not]])
+ ifTrue: [extent := width @ (extent y max: height)].
+ posX := newBounds left.
+ posY := newBounds top.
+
+ "Compute extra horizontal space"
+ extra := extent x - width.
+ extra := extra max: 0.
+ extra > 0
+ ifTrue:
+ [vFill
+ ifTrue: [width := extent x]
+ ifFalse:
+ [centering := properties wrapCentering.
+ centering == #bottomRight ifTrue: [posX := posX + extra].
+ centering == #center ifTrue: [posX := posX + (extra // 2)]]].
+
+
+ "Compute extra vertical space"
+ extra := extent y - height.
+ extra := extra max: 0.
+ extraPerCell := 0.
+ extra > 0
+ ifTrue:
+ [sum isZero
+ ifTrue:
+ ["extra space but no #spaceFillers"
+
+ centering := properties listCentering.
+ centering == #bottomRight ifTrue: [posY := posY + extra].
+ centering == #center ifTrue: [posY := posY + (extra // 2)]]
+ ifFalse: [extraPerCell := extra asFloat / sum asFloat]].
+ n := 0.
+ extra := last := 0.
+ cell := first.
+ [cell isNil] whileFalse:
+ [n := n + 1.
+ height := cell cellSize.
+ (extraPerCell > 0 and: [cell vSpaceFill])
+ ifTrue:
+ [extra := (last := extra) + (extraPerCell * cell extraSpace).
+ amount := extra truncated - last truncated.
+ height := height + amount].
+ cell target layoutInBounds: (posX @ posY extent: width @ height).
+ posY := posY + height + inset.
+ cell := cell nextCell]!
Item was added:
+ ----- Method: TableLayout>>minExtentHorizontal: (in category 'optimized') -----
+ minExtentHorizontal: aMorph
+ "Return the minimal size aMorph's children would require given the new bounds"
+
+ | inset minX minY maxX maxY n size width height |
+ size := properties minCellSize asPoint.
+ minX := size x.
+ minY := size y.
+ size := properties maxCellSize asPoint.
+ maxX := size x.
+ maxY := size y.
+ inset := properties cellInset asPoint.
+ n := 0.
+ width := height := 0.
+ aMorph submorphsDo:
+ [:m | | sizeX sizeY |
+ m disableTableLayout
+ ifFalse:
+ [n := n + 1.
+ size := m minExtent.
+ sizeX := size x.
+ sizeY := size y.
+ sizeX < minX
+ ifTrue: [sizeX := minX]
+ ifFalse: [sizeX := sizeX min: maxX].
+ sizeY < minY
+ ifTrue: [sizeY := minY]
+ ifFalse: [sizeY := sizeY min: maxY].
+ width := width + sizeX.
+ sizeY > height ifTrue: [height := sizeY]]].
+ n > 1 ifTrue: [width := width + ((n - 1) * inset x)].
+ ^minExtentCache := width @ height!
Item was added:
+ ----- Method: TableLayout>>minExtentOf:in: (in category 'layout') -----
+ minExtentOf: aMorph in: box
+ "Return the minimal size aMorph's children would require given the new bounds"
+
+ | cells arrangement horizontal newBounds minX minY dir |
+ minExtentCache isNil ifFalse: [^minExtentCache].
+ aMorph hasSubmorphs ifFalse: [^0 @ 0].
+ properties := aMorph assureTableProperties.
+ (properties wrapDirection == #none and: [properties cellSpacing == #none])
+ ifTrue:
+ ["Get into the fast lane"
+
+ dir := properties listDirection.
+ (dir == #leftToRight or: [dir == #rightToLeft])
+ ifTrue: [^self minExtentHorizontal: aMorph].
+ (dir == #topToBottom or: [dir == #bottomToTop])
+ ifTrue: [^self minExtentVertical: aMorph]].
+ newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint.
+ horizontal := (properties listDirection == #topToBottom
+ or: [properties listDirection == #bottomToTop]) not.
+ "Step 1: Compute the minimum extent for all the children of aMorph"
+ cells := self
+ computeCellSizes: aMorph
+ in: (0 @ 0 corner: newBounds extent)
+ horizontal: horizontal.
+ "Step 2: Compute the arrangement of the cells for each row and column"
+ arrangement := self
+ computeCellArrangement: cells
+ in: newBounds
+ horizontal: horizontal
+ target: aMorph.
+ "Step 3: Extract the minimum size out of the arrangement"
+ minX := minY := 0.
+ arrangement do:
+ [:cell |
+ minX := minX max: cell cellSize x + cell extraSpace x.
+ minY := minY + cell cellSize y + cell extraSpace y].
+ minExtentCache := horizontal ifTrue: [minX @ minY] ifFalse: [minY @ minX].
+ ^minExtentCache!
Item was added:
+ ----- Method: TableLayout>>minExtentVertical: (in category 'optimized') -----
+ minExtentVertical: aMorph
+ "Return the minimal size aMorph's children would require given the new bounds"
+
+ | inset minX minY maxX maxY n size width height |
+ size := properties minCellSize asPoint.
+ minX := size x.
+ minY := size y.
+ size := properties maxCellSize asPoint.
+ maxX := size x.
+ maxY := size y.
+ inset := properties cellInset asPoint.
+ n := 0.
+ width := height := 0.
+ aMorph submorphsDo:
+ [:m | | sizeY sizeX |
+ m disableTableLayout
+ ifFalse:
+ [n := n + 1.
+ size := m minExtent.
+ sizeX := size x.
+ sizeY := size y.
+ sizeX < minX
+ ifTrue: [sizeX := minX]
+ ifFalse: [sizeX := sizeX min: maxX].
+ sizeY < minY
+ ifTrue: [sizeY := minY]
+ ifFalse: [sizeY := sizeY min: maxY].
+ height := height + sizeY.
+ sizeX > width ifTrue: [width := sizeX]]].
+ n > 1 ifTrue: [height := height + ((n - 1) * inset y)].
+ ^minExtentCache := width @ height!
Item was added:
+ ----- Method: TableLayout>>placeCells:in:horizontal:target: (in category 'layout') -----
+ placeCells: arrangement in: newBounds horizontal: aBool target: aMorph
+ "Place the morphs within the cells accordingly"
+
+ | xDir yDir anchor yDist place cell xDist cellRect corner inset |
+ inset := properties cellInset.
+ (inset isNumber and: [inset isZero]) ifTrue: [inset := nil].
+ aBool
+ ifTrue:
+ ["horizontal layout"
+
+ properties listDirection == #rightToLeft
+ ifTrue:
+ [xDir := -1 @ 0.
+ properties wrapDirection == #bottomToTop
+ ifTrue:
+ [yDir := 0 @ -1.
+ anchor := newBounds bottomRight]
+ ifFalse:
+ [yDir := 0 @ 1.
+ anchor := newBounds topRight]]
+ ifFalse:
+ [xDir := 1 @ 0.
+ properties wrapDirection == #bottomToTop
+ ifTrue:
+ [yDir := 0 @ -1.
+ anchor := newBounds bottomLeft]
+ ifFalse:
+ [yDir := 0 @ 1.
+ anchor := newBounds topLeft]]]
+ ifFalse:
+ ["vertical layout"
+
+ properties listDirection == #bottomToTop
+ ifTrue:
+ [xDir := 0 @ -1.
+ properties wrapDirection == #rightToLeft
+ ifTrue:
+ [yDir := -1 @ 0.
+ anchor := newBounds bottomRight]
+ ifFalse:
+ [yDir := 1 @ 0.
+ anchor := newBounds bottomLeft]]
+ ifFalse:
+ [xDir := 0 @ 1.
+ anchor := properties wrapDirection == #rightToLeft
+ ifTrue:
+ [yDir := -1 @ 0.
+ newBounds topRight]
+ ifFalse:
+ [yDir := 1 @ 0.
+ newBounds topLeft]]].
+ 1 to: arrangement size
+ do:
+ [:i |
+ cell := arrangement at: i.
+ cell extraSpace ifNotNil: [anchor := anchor + (cell extraSpace y * yDir)].
+ yDist := cell cellSize y * yDir. "secondary advance direction"
+ place := anchor.
+ cell := cell nextCell.
+ [cell isNil] whileFalse:
+ [cell extraSpace ifNotNil: [place := place + (cell extraSpace x * xDir)].
+ xDist := cell cellSize x * xDir. "primary advance direction"
+ corner := place + xDist + yDist.
+ cellRect := Rectangle origin: (place min: corner)
+ corner: (place max: corner).
+ inset ifNotNil: [cellRect := cellRect insetBy: inset].
+ cell target layoutInBounds: cellRect.
+ place := place + xDist.
+ cell := cell nextCell].
+ anchor := anchor + yDist]!
Item was added:
+ LayoutProperties subclass: #TableLayoutProperties
+ instanceVariableNames: 'cellInset cellPositioning cellSpacing layoutInset listCentering listDirection listSpacing reverseTableCells rubberBandCells wrapCentering wrapDirection minCellSize maxCellSize'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Layouts'!
Item was added:
+ ----- Method: TableLayoutProperties>>cellInset (in category 'table defaults') -----
+ cellInset
+ ^cellInset!
Item was added:
+ ----- Method: TableLayoutProperties>>cellInset: (in category 'accessing') -----
+ cellInset: aNumber
+ cellInset := aNumber!
Item was added:
+ ----- Method: TableLayoutProperties>>cellPositioning (in category 'table defaults') -----
+ cellPositioning
+ ^cellPositioning!
Item was added:
+ ----- Method: TableLayoutProperties>>cellPositioning: (in category 'accessing') -----
+ cellPositioning: aSymbol
+ cellPositioning := aSymbol!
Item was added:
+ ----- Method: TableLayoutProperties>>cellSpacing (in category 'table defaults') -----
+ cellSpacing
+ ^cellSpacing!
Item was added:
+ ----- Method: TableLayoutProperties>>cellSpacing: (in category 'accessing') -----
+ cellSpacing: aSymbol
+ cellSpacing := aSymbol.!
Item was added:
+ ----- Method: TableLayoutProperties>>includesTableProperties (in category 'testing') -----
+ includesTableProperties
+ ^true!
Item was added:
+ ----- Method: TableLayoutProperties>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ cellSpacing := listSpacing := wrapDirection := #none.
+ cellPositioning := #center.
+ listCentering := wrapCentering := #topLeft.
+ listDirection := #topToBottom.
+ reverseTableCells := rubberBandCells := false.
+ layoutInset := cellInset := minCellSize := 0.
+ maxCellSize := 1073741823. "SmallInteger maxVal"
+ !
Item was added:
+ ----- Method: TableLayoutProperties>>layoutInset (in category 'table defaults') -----
+ layoutInset
+ ^layoutInset!
Item was added:
+ ----- Method: TableLayoutProperties>>layoutInset: (in category 'accessing') -----
+ layoutInset: aNumber
+ layoutInset := aNumber!
Item was added:
+ ----- Method: TableLayoutProperties>>listCentering (in category 'table defaults') -----
+ listCentering
+ ^listCentering!
Item was added:
+ ----- Method: TableLayoutProperties>>listCentering: (in category 'accessing') -----
+ listCentering: aSymbol
+ listCentering := aSymbol!
Item was added:
+ ----- Method: TableLayoutProperties>>listDirection (in category 'table defaults') -----
+ listDirection
+ ^listDirection!
Item was added:
+ ----- Method: TableLayoutProperties>>listDirection: (in category 'accessing') -----
+ listDirection: aSymbol
+ listDirection := aSymbol.!
Item was added:
+ ----- Method: TableLayoutProperties>>listSpacing (in category 'table defaults') -----
+ listSpacing
+ ^listSpacing!
Item was added:
+ ----- Method: TableLayoutProperties>>listSpacing: (in category 'accessing') -----
+ listSpacing: aSymbol
+ listSpacing := aSymbol!
Item was added:
+ ----- Method: TableLayoutProperties>>maxCellSize (in category 'table defaults') -----
+ maxCellSize
+ ^maxCellSize!
Item was added:
+ ----- Method: TableLayoutProperties>>maxCellSize: (in category 'accessing') -----
+ maxCellSize: aNumber
+ maxCellSize := aNumber.!
Item was added:
+ ----- Method: TableLayoutProperties>>minCellSize (in category 'table defaults') -----
+ minCellSize
+ ^minCellSize!
Item was added:
+ ----- Method: TableLayoutProperties>>minCellSize: (in category 'accessing') -----
+ minCellSize: aNumber
+ minCellSize := aNumber.!
Item was added:
+ ----- Method: TableLayoutProperties>>reverseTableCells (in category 'table defaults') -----
+ reverseTableCells
+ ^reverseTableCells!
Item was added:
+ ----- Method: TableLayoutProperties>>reverseTableCells: (in category 'accessing') -----
+ reverseTableCells: aBool
+ reverseTableCells := aBool!
Item was added:
+ ----- Method: TableLayoutProperties>>rubberBandCells (in category 'table defaults') -----
+ rubberBandCells
+ ^rubberBandCells!
Item was added:
+ ----- Method: TableLayoutProperties>>rubberBandCells: (in category 'accessing') -----
+ rubberBandCells: aBool
+ rubberBandCells := aBool.!
Item was added:
+ ----- Method: TableLayoutProperties>>wrapCentering (in category 'table defaults') -----
+ wrapCentering
+ ^wrapCentering!
Item was added:
+ ----- Method: TableLayoutProperties>>wrapCentering: (in category 'accessing') -----
+ wrapCentering: aSymbol
+ wrapCentering := aSymbol!
Item was added:
+ ----- Method: TableLayoutProperties>>wrapDirection (in category 'table defaults') -----
+ wrapDirection
+ ^wrapDirection!
Item was added:
+ ----- Method: TableLayoutProperties>>wrapDirection: (in category 'accessing') -----
+ wrapDirection: aSymbol
+ wrapDirection := aSymbol!
Item was added:
+ ----- Method: Text>>asMorph (in category '*Morphic-converting') -----
+ asMorph
+ ^ self asTextMorph!
Item was added:
+ ----- Method: Text>>asStringMorph (in category '*Morphic-converting') -----
+ asStringMorph
+ ^ StringMorph
+ contents: self string
+ font: (self fontAt: 1 withStyle: TextStyle default)
+ emphasis: (self emphasisAt: 1)!
Item was added:
+ ----- Method: Text>>asTextMorph (in category '*Morphic-converting') -----
+ asTextMorph
+ ^ TextMorph new contentsAsIs: self!
Item was added:
+ TextAttribute subclass: #TextAnchor
+ instanceVariableNames: 'anchoredMorph'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !TextAnchor commentStamp: 'md 8/10/2006 11:52' prior: 0!
+ TextAnchors support anchoring of images in text. A TextAnchor exists as an attribute of text emphasis, and it gets control like a FontReference, through the emphasizeScanner: message. Depending on whether its anchoredMorph is a Morph or a Form, it repositions the morph, or displays the form respectively. The coordination between composition, display and selection can best be understood by browsing the various implementations of placeEmbeddedObject:.
+
+ In the morphic world, simply embed any form or morph in text.
+
+ Workspace new
+ contents: (Text withAll: 'foo') , (Text string: '*' attribute: (TextAnchor new anchoredMorph: MenuIcons confirmIcon)) , (Text withAll: 'bar');
+ openLabel: 'Text with Form'.
+
+ Workspace new
+ contents: (Text withAll: 'foo') , (Text string: '*' attribute: (TextAnchor new anchoredMorph: EllipseMorph new)) , (Text withAll: 'bar');
+ openLabel: 'Text with Morph'.
+
+ In this case you select a piece of the screen, and it gets anchored to a one-character text in the editor's past buffer. If you then paste into some other text, you will see the image as an embedded image.!
Item was added:
+ ----- Method: TextAnchor>>= (in category 'comparing') -----
+ = other
+ ^ (other class == self class)
+ and: [other anchoredMorph == anchoredMorph]!
Item was added:
+ ----- Method: TextAnchor>>anchoredMorph (in category 'accessing') -----
+ anchoredMorph
+ ^ anchoredMorph!
Item was added:
+ ----- Method: TextAnchor>>anchoredMorph: (in category 'accessing') -----
+ anchoredMorph: aMorph
+ anchoredMorph := aMorph!
Item was added:
+ ----- Method: TextAnchor>>couldDeriveFromPrettyPrinting (in category 'accessing') -----
+ couldDeriveFromPrettyPrinting
+ ^ false!
Item was added:
+ ----- Method: TextAnchor>>emphasizeScanner: (in category 'visiting') -----
+ emphasizeScanner: scanner
+ "Do nothing for emphasizing the scanner - if the anchor is valid a #embeddedObject will be encountered by the scanner and do the real thing"!
Item was added:
+ ----- Method: TextAnchor>>hash (in category 'comparing') -----
+ hash
+ "#hash is re-implemented because #= is re-implemented"
+ ^anchoredMorph identityHash!
Item was added:
+ ----- Method: TextAnchor>>mayBeExtended (in category 'accessing') -----
+ mayBeExtended
+ "A textAnchor is designed to modify only a single character, and therefore must not be extended by the ParagraphEditor's emphasisHere facility"
+ ^ false!
Item was added:
+ Object subclass: #TextContainer
+ instanceVariableNames: 'textMorph shadowForm vertProfile minWidth rectangleCache fillsOwner avoidsOcclusions'
+ classVariableNames: 'OuterMargin'
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !TextContainer commentStamp: '<historical>' prior: 0!
+ A TextContainer models the shape of an ownerMorph, possibly occluded by one or more occludingMorphs, and scans this shape to provide a list of rectangles suitable for layout of text. It does this by displaying the shadow of the ownerMorph in black, and any occludingMorphs in white, on its shadowForm. It then scans horizontal strips of appropriate height to find unbroken intervals of black, greater than minWidth in extent. Conputation of the rectangles is done on demand, and results are cached so that text can be redisplayed without having to recompute the rectangles.!
Item was added:
+ ----- Method: TextContainer class>>initialize (in category 'class initialization') -----
+ initialize "TextContainer initialize"
+ OuterMargin := 2!
Item was added:
+ ----- Method: TextContainer>>avoidsOcclusions (in category 'access') -----
+ avoidsOcclusions
+ ^ avoidsOcclusions ifNil: [false]!
Item was added:
+ ----- Method: TextContainer>>avoidsOcclusions: (in category 'access') -----
+ avoidsOcclusions: aBoolean
+ avoidsOcclusions := aBoolean.
+ self releaseCachedState!
Item was added:
+ ----- Method: TextContainer>>bottom (in category 'container protocol') -----
+ bottom
+ "Note we should really check for contiguous pixels here"
+ ^ (self vertProfile findLast: [:count | count >= minWidth])
+ + shadowForm offset y!
Item was added:
+ ----- Method: TextContainer>>bounds (in category 'private') -----
+ bounds
+ | bounds theText |
+ self fillsOwner ifFalse: [^ textMorph textBounds].
+ theText := textMorph.
+ bounds := theText owner innerBounds.
+ bounds := bounds insetBy: (textMorph valueOfProperty: #margins ifAbsent: [1 at 1]).
+ theText owner submorphsBehind: theText do:
+ [:m | bounds swallow: m fullBounds].
+ ^ bounds!
Item was added:
+ ----- Method: TextContainer>>computeShadow (in category 'private') -----
+ computeShadow
+ | canvas bounds theText |
+ bounds := self bounds.
+ theText := textMorph.
+ canvas := (Display defaultCanvasClass extent: bounds extent depth: 1)
+ shadowColor: Color black.
+ canvas translateBy: bounds topLeft negated during:[:tempCanvas| | back |
+ self fillsOwner
+ ifTrue: [tempCanvas fullDrawMorph: (theText owner copyWithoutSubmorph: theText)]
+ ifFalse: [tempCanvas fillRectangle: textMorph bounds color: Color black].
+ self avoidsOcclusions ifTrue:
+ [back := tempCanvas form deepCopy.
+ tempCanvas form fillWhite.
+ theText owner submorphsInFrontOf: theText do:
+ [:m | (textMorph isLinkedTo: m)
+ ifTrue: []
+ ifFalse: [tempCanvas fullDrawMorph: m]].
+ back displayOn: tempCanvas form at: 0 at 0 rule: Form reverse].
+ ].
+ shadowForm := canvas form offset: bounds topLeft.
+ vertProfile := shadowForm yTallyPixelValue: 1 orNot: false.
+ rectangleCache := Dictionary new.
+ ^ shadowForm!
Item was added:
+ ----- Method: TextContainer>>fillsOwner (in category 'access') -----
+ fillsOwner
+ ^ fillsOwner ifNil: [true]!
Item was added:
+ ----- Method: TextContainer>>fillsOwner: (in category 'access') -----
+ fillsOwner: aBoolean
+ fillsOwner := aBoolean.
+ self releaseCachedState!
Item was added:
+ ----- Method: TextContainer>>for:minWidth: (in category 'private') -----
+ for: aTextMorph minWidth: wid
+ textMorph := aTextMorph.
+ minWidth := wid.
+ fillsOwner := true.
+ avoidsOcclusions := false.!
Item was added:
+ ----- Method: TextContainer>>left (in category 'container protocol') -----
+ left
+ ^ textMorph owner left!
Item was added:
+ ----- Method: TextContainer>>paragraphClass (in category 'access') -----
+ paragraphClass
+ ^ NewParagraph!
Item was added:
+ ----- Method: TextContainer>>rectanglesAt:height: (in category 'container protocol') -----
+ rectanglesAt: lineY height: lineHeight
+ "Return a list of rectangles that are at least minWidth wide
+ in the specified horizontal strip of the shadowForm.
+ Cache the results for later retrieval if the owner does not change."
+
+ | hProfile rects thisWidth thisX count pair outerWidth lineRect lineForm |
+ pair := Array with: lineY with: lineHeight.
+ rects := rectangleCache at: pair ifAbsent: [nil].
+ rects ifNotNil: [^rects].
+ outerWidth := minWidth + (2 * OuterMargin).
+ self shadowForm. "Compute the shape"
+ lineRect := 0 @ (lineY - shadowForm offset y)
+ extent: shadowForm width @ lineHeight.
+ lineForm := shadowForm copy: lineRect.
+
+ "Check for a full line -- frequent case"
+ (lineForm tallyPixelValues second) = lineRect area
+ ifTrue:
+ [rects := Array with: (shadowForm offset x @ lineY extent: lineRect extent)]
+ ifFalse:
+ ["No such luck -- scan the horizontal profile for segments of minWidth"
+
+ hProfile := lineForm xTallyPixelValue: 1 orNot: false.
+ rects := OrderedCollection new.
+ thisWidth := 0.
+ thisX := 0.
+ 1 to: hProfile size
+ do:
+ [:i |
+ count := hProfile at: i.
+ count >= lineHeight
+ ifTrue: [thisWidth := thisWidth + 1]
+ ifFalse:
+ [thisWidth >= outerWidth
+ ifTrue:
+ [rects addLast: ((thisX + shadowForm offset x) @ lineY
+ extent: thisWidth @ lineHeight)].
+ thisWidth := 0.
+ thisX := i]].
+ thisWidth >= outerWidth
+ ifTrue:
+ [rects addLast: ((thisX + shadowForm offset x) @ lineY
+ extent: thisWidth @ lineHeight)]].
+ rects := rects collect: [:r | r insetBy: OuterMargin @ 0].
+ rectangleCache at: pair put: rects.
+ ^rects!
Item was added:
+ ----- Method: TextContainer>>releaseCachedState (in category 'access') -----
+ releaseCachedState
+
+ shadowForm := nil.
+ vertProfile := nil.
+ rectangleCache := Dictionary new.
+ !
Item was added:
+ ----- Method: TextContainer>>shadowForm (in category 'private') -----
+ shadowForm
+ shadowForm ifNil: [self computeShadow].
+ ^ shadowForm!
Item was added:
+ ----- Method: TextContainer>>textMorph (in category 'access') -----
+ textMorph
+ ^ textMorph!
Item was added:
+ ----- Method: TextContainer>>top (in category 'container protocol') -----
+ top
+ "Note we should really check for contiguous pixels here"
+ | outerWidth |
+ outerWidth := minWidth + (2*OuterMargin).
+ ^ (self vertProfile findFirst: [:count | count >= outerWidth]) - 1
+ + shadowForm offset y!
Item was added:
+ ----- Method: TextContainer>>topLeft (in category 'container protocol') -----
+ topLeft "for compatibility"
+ ^ textMorph owner topLeft!
Item was added:
+ ----- Method: TextContainer>>translateBy: (in category 'container protocol') -----
+ translateBy: delta
+ self releaseCachedState!
Item was added:
+ ----- Method: TextContainer>>vertProfile (in category 'private') -----
+ vertProfile
+ vertProfile ifNil: [self computeShadow].
+ ^ vertProfile!
Item was added:
+ ----- Method: TextContainer>>width (in category 'container protocol') -----
+ width "for compatibility"
+ ^ textMorph owner width!
Item was added:
+ Editor subclass: #TextEditor
+ instanceVariableNames: 'model paragraph markBlock pointBlock beginTypeInIndex emphasisHere lastParenLocation otherInterval oldInterval typeAhead'
+ classVariableNames: 'AutoEnclose AutoIndent ChangeText FindText UndoInterval UndoMessage UndoParagraph UndoSelection Undone'
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+ TextEditor class
+ instanceVariableNames: 'cmdActions shiftCmdActions yellowButtonMenu shiftedYellowButtonMenu'!
+
+ !TextEditor commentStamp: '<historical>' prior: 0!
+ See comment in Editor.
+
+ My instances edit Text, this is, they support multiple lines and TextAttributes.
+ They have no specific facilities for editing Smalltalk code. Those are found in SmalltalkEditor.!
+ TextEditor class
+ instanceVariableNames: 'cmdActions shiftCmdActions yellowButtonMenu shiftedYellowButtonMenu'!
Item was added:
+ ----- Method: TextEditor class>>abandonChangeText (in category 'class initialization') -----
+ abandonChangeText
+ "Call this to get out of the maddening situation in which the system keeps aggressively trying to do a replacement that you no longer wish to make, every time you make choose a new method in a list."
+ ChangeText := FindText
+
+ "
+ TextEditor abandonChangeText
+ "!
Item was added:
+ ----- Method: TextEditor class>>autoEnclose (in category 'accessing') -----
+ autoEnclose
+ <preference: 'Auto Enclose'
+ category: 'Morphic'
+ description: 'When true, typing an opening parenthesis, bracket or square-bracket will also add its corresponding closing character in front of the cursor.'
+ type: #Boolean>
+ ^ AutoEnclose ifNil: [ false ]!
Item was added:
+ ----- Method: TextEditor class>>autoEnclose: (in category 'accessing') -----
+ autoEnclose: aBoolean
+ AutoEnclose := aBoolean!
Item was added:
+ ----- Method: TextEditor class>>autoIndent (in category 'accessing') -----
+ autoIndent
+ <preference: 'Auto Indent'
+ category: 'Morphic'
+ description: 'When true, tabs will be inserted after pressing Enter | Return such that the new line will be indented equally with the previous line.'
+ type: #Boolean>
+ ^ AutoIndent ifNil: [ true ]!
Item was added:
+ ----- Method: TextEditor class>>autoIndent: (in category 'accessing') -----
+ autoIndent: aBoolean
+ AutoIndent := aBoolean!
Item was added:
+ ----- Method: TextEditor class>>cmdActions (in category 'accessing') -----
+ cmdActions
+ ^cmdActions!
Item was added:
+ ----- Method: TextEditor class>>initialize (in category 'class initialization') -----
+ initialize
+ "Initialize the keyboard shortcut maps and the shared buffers
+ for copying text across views and managing again and undo."
+
+ "TextEditor initialize"
+
+ UndoSelection := FindText := ChangeText := Text new.
+ UndoMessage := Message selector: #halt.
+
+ self initializeCmdKeyShortcuts.
+ self initializeShiftCmdKeyShortcuts.
+ self initializeYellowButtonMenu.
+ self initializeShiftedYellowButtonMenu!
Item was added:
+ ----- Method: TextEditor class>>initializeCmdKeyShortcuts (in category 'keyboard shortcut tables') -----
+ initializeCmdKeyShortcuts
+ "Initialize the (unshifted) command-key (or alt-key) shortcut table."
+
+ "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
+
+ "TextEditor initialize"
+
+ | cmdMap cmds |
+ cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash"
+ cmdMap at: 1 + 1 put: #cursorHome:. "home key"
+ cmdMap at: 4 + 1 put: #cursorEnd:. "end key"
+ cmdMap at: 8 + 1 put: #backspace:. "ctrl-H or delete key"
+ cmdMap at: 11 + 1 put: #cursorPageUp:. "page up key"
+ cmdMap at: 12 + 1 put: #cursorPageDown:. "page down key"
+ cmdMap at: 13 + 1 put: #crWithIndent:. "cmd-Return"
+ cmdMap at: 27 + 1 put: #offerMenuFromEsc:. "escape key"
+ cmdMap at: 28 + 1 put: #cursorLeft:. "left arrow key"
+ cmdMap at: 29 + 1 put: #cursorRight:. "right arrow key"
+ cmdMap at: 30 + 1 put: #cursorUp:. "up arrow key"
+ cmdMap at: 31 + 1 put: #cursorDown:. "down arrow key"
+ cmdMap at: 32 + 1 put: #selectWord:. "space bar key"
+ cmdMap at: 127 + 1 put: #forwardDelete:. "del key"
+
+ '0123456789-='
+ do: [:char | cmdMap at: char asciiValue + 1 put: #changeEmphasis:].
+
+ '([<{|"''' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:].
+
+ cmds := #($a #selectAll: $c #copySelection: $e #exchange: $f #find: $g #findAgain: $h #setSearchString: $k #offerFontMenu: $u #align: $v #paste: $w #backWord: $x #cut: $y #swapChars: $z #undo:).
+ 1 to: cmds size
+ by: 2
+ do: [:i | cmdMap at: (cmds at: i) asciiValue + 1 put: (cmds at: i + 1)].
+
+ cmdActions := cmdMap!
Item was added:
+ ----- Method: TextEditor class>>initializeShiftCmdKeyShortcuts (in category 'keyboard shortcut tables') -----
+ initializeShiftCmdKeyShortcuts
+ "Initialize the shift-command-key (or control-key) shortcut table."
+ "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
+ "wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the
+ capitalized versions of the letters.
+ TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values."
+
+ "TextEditor initialize"
+
+ | cmdMap cmds |
+
+ "shift-command and control shortcuts"
+ cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash"
+ cmdMap at: ( 1 + 1) put: #cursorHome:. "home key"
+ cmdMap at: ( 4 + 1) put: #cursorEnd:. "end key"
+ cmdMap at: ( 8 + 1) put: #forwardDelete:. "ctrl-H or delete key"
+ cmdMap at: (11 + 1) put: #cursorPageUp:. "page up key"
+ cmdMap at: (12 + 1) put: #cursorPageDown:. "page down key"
+ cmdMap at: (13 + 1) put: #crWithIndent:. "ctrl-Return"
+ cmdMap at: (27 + 1) put: #offerMenuFromEsc:. "escape key"
+ cmdMap at: (28 + 1) put: #cursorLeft:. "left arrow key"
+ cmdMap at: (29 + 1) put: #cursorRight:. "right arrow key"
+ cmdMap at: (30 + 1) put: #cursorUp:. "up arrow key"
+ cmdMap at: (31 + 1) put: #cursorDown:. "down arrow key"
+ cmdMap at: (32 + 1) put: #selectWord:. "space bar key"
+ cmdMap at: (45 + 1) put: #changeEmphasis:. "cmd-sh-minus"
+ cmdMap at: (61 + 1) put: #changeEmphasis:. "cmd-sh-plus"
+ cmdMap at: (127 + 1) put: #forwardDelete:. "del key"
+
+ "On some keyboards, these characters require a shift"
+ '([<{|"''9' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:].
+
+ "NB: sw 12/9/2001 commented out the idiosyncratic line just below, which was grabbing shift-esc in the text editor and hence which argued with the wish to have shift-esc be a universal gesture for escaping the local context and calling up the desktop menu."
+ "cmdMap at: (27 + 1) put: #shiftEnclose:." "ctrl-["
+
+ "'""''(' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose:]."
+
+ cmds := #(
+ $c compareToClipboard:
+ $d duplicate:
+ $h cursorTopHome:
+ $j doAgainMany:
+ $k changeStyle:
+ $l outdent:
+ $m selectCurrentTypeIn:
+ $r indent:
+ $s search:
+ $u changeLfToCr:
+ $x makeLowercase:
+ $y makeUppercase:
+ $z makeCapitalized:
+ ).
+ 1 to: cmds size by: 2 do: [ :i |
+ cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1). "plain keys"
+ cmdMap at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1). "shifted keys"
+ cmdMap at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1). "ctrl keys"
+ ].
+ shiftCmdActions := cmdMap!
Item was added:
+ ----- Method: TextEditor class>>initializeShiftedYellowButtonMenu (in category 'keyboard shortcut tables') -----
+ initializeShiftedYellowButtonMenu
+ "Initialize the yellow button pop-up menu and corresponding messages."
+
+ "TextEditor initialize"
+ "
+ shiftedYellowButtonMenu := {
+ {'set font... (k)' translated. #offerFontMenu}.
+ {'set style... (K)' translated. #changeStyle}.
+ {'set alignment...' translated. #chooseAlignment}.
+ #-.
+ {'more...' translated. #yellowButtonActivity}.
+ }
+ "
+ shiftedYellowButtonMenu := yellowButtonMenu!
Item was added:
+ ----- Method: TextEditor class>>initializeYellowButtonMenu (in category 'keyboard shortcut tables') -----
+ initializeYellowButtonMenu
+ "Initialize the yellow button pop-up menu and corresponding messages."
+
+ "TextEditor initialize"
+
+ yellowButtonMenu := MenuMorph fromArray: {
+ {'find...(f)' translated. #find}.
+ {'find again (g)' translated. #findAgain}.
+ {'set search string (h)' translated. #setSearchString}.
+ #-.
+ {'do again (j)' translated. #again}.
+ {'undo (z)' translated. #undo}.
+ #-.
+ {'copy (c)' translated. #copySelection}.
+ {'cut (x)' translated. #cut}.
+ {'paste (v)' translated. #paste}.
+ {'paste...' translated. #pasteRecent}.
+ #-.
+ {'set font... (k)' translated. #offerFontMenu}.
+ {'set style... (K)' translated. #changeStyle}.
+ {'set alignment...' translated. #chooseAlignment}.
+ "
+ #-.
+ {'more...' translated. #shiftedTextPaneMenuRequest}.
+ "
+ }!
Item was added:
+ ----- Method: TextEditor class>>shiftCmdActions (in category 'accessing') -----
+ shiftCmdActions
+ ^shiftCmdActions!
Item was added:
+ ----- Method: TextEditor class>>shiftedYellowButtonMenu (in category 'class initialization') -----
+ shiftedYellowButtonMenu
+ "Answer the menu to be presented when the yellow button is pressed while the shift key is down"
+
+ ^ shiftedYellowButtonMenu!
Item was added:
+ ----- Method: TextEditor class>>yellowButtonMenu (in category 'class initialization') -----
+ yellowButtonMenu
+
+ ^ yellowButtonMenu!
Item was added:
+ ----- Method: TextEditor>>abandonChangeText (in category 'editing keys') -----
+ abandonChangeText
+ ^self class abandonChangeText!
Item was added:
+ ----- Method: TextEditor>>accept (in category 'menu messages') -----
+ accept
+ "Save the current text of the text being edited as the current acceptable version for purposes of canceling. Allow my morph to take appropriate action"
+ morph acceptContents!
Item was added:
+ ----- Method: TextEditor>>addString: (in category 'typing support') -----
+ addString: aString
+ self typeAhead nextPutAll: aString!
Item was added:
+ ----- Method: TextEditor>>afterSelectionInsertAndSelect: (in category 'new selection') -----
+ afterSelectionInsertAndSelect: aString
+
+ self insertAndSelect: aString at: self stopIndex !
Item was added:
+ ----- Method: TextEditor>>again (in category 'menu messages') -----
+ again
+ "Text substitution. If the left shift key is down, the substitution is made
+ throughout the entire Paragraph. Otherwise, only the next possible
+ substitution is made.
+ Undoer & Redoer: #undoAgain:andReselect:typedKey:."
+
+ "If last command was also 'again', use same keys as before"
+ self againOrSame: (UndoMessage sends: #undoAgain:andReselect:typedKey:)!
Item was added:
+ ----- Method: TextEditor>>againOnce: (in category 'private') -----
+ againOnce: indices
+ "Find the next occurrence of FindText. If none, answer false.
+ Append the start index of the occurrence to the stream indices, and, if
+ ChangeText is not the same object as FindText, replace the occurrence by it.
+ Note that the search is case-sensitive for replacements, otherwise not."
+
+ | where |
+ where := self text
+ findString: FindText
+ startingAt: self stopIndex
+ caseSensitive: ((ChangeText ~~ FindText) or: [Preferences caseSensitiveFinds]).
+ where = 0 ifTrue: [^ false].
+
+ self deselect; selectInvisiblyFrom: where to: where + FindText size - 1. "Repeat it here. Senders beware: only one of these should last"
+
+ ChangeText ~~ FindText ifTrue: [ self zapSelectionWith: ChangeText ].
+ indices nextPut: where.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>againOrSame: (in category 'private') -----
+ againOrSame: useOldKeys
+ "Subroutine of search: and again. If useOldKeys, use same FindText and ChangeText as before.
+ 1/26/96 sw: real worked moved to againOrSame:many:"
+
+ self againOrSame: useOldKeys many: false.
+
+ (morph respondsTo: #editView)
+ ifTrue: [morph editView selectionInterval: self selectionInterval]!
Item was added:
+ ----- Method: TextEditor>>againOrSame:many: (in category 'private') -----
+ againOrSame: useOldKeys many: many
+ "Subroutine of search: and again. If useOldKeys, use same FindText and ChangeText as before. If many is true, do it repeatedly. Created 1/26/96 sw by adding the many argument to #againOrSame."
+
+ | home indices wasTypedKey |
+
+ home := self selectionInterval. "what was selected when 'again' was invoked"
+
+ "If new keys are to be picked..."
+ useOldKeys ifFalse: [ "Choose as FindText..."
+ FindText := UndoSelection. "... the last thing replaced."
+ "If the last command was in another paragraph, ChangeText is set..."
+ paragraph == UndoParagraph ifTrue: [ "... else set it now as follows."
+ UndoInterval ~= home ifTrue: [self selectInterval: UndoInterval]. "blink"
+ ChangeText := ((UndoMessage sends: #undoCutCopy:) and: [self hasSelection])
+ ifTrue: [FindText] "== objects signal no model-locking by 'undo copy'"
+ ifFalse: [self selection]]]. "otherwise, change text is last-replaced text"
+
+ (wasTypedKey := FindText size = 0)
+ ifTrue: [ "just inserted at a caret"
+ home := self selectionInterval.
+ self replaceSelectionWith: self nullText. "delete search key..."
+ FindText := ChangeText] "... and search for it, without replacing"
+ ifFalse: [ "Show where the search will start"
+ home last = self selectionInterval last ifFalse: [
+ self selectInterval: home]].
+
+ "Find and Change, recording start indices in the array"
+ indices := WriteStream on: (Array new: 20). "an array to store change locs"
+ [(self againOnce: indices) & many] whileTrue. "<-- this does the work"
+ "Last find was also stored in markBlock / pointBlock"
+ indices isEmpty ifTrue: [ "none found"
+ self flash.
+ wasTypedKey ifFalse: [^self]].
+
+ (many | wasTypedKey) ifFalse: [ "after undo, select this replacement"
+ home := self startIndex to:
+ self startIndex + UndoSelection size - 1].
+
+ self undoer: #undoAgain:andReselect:typedKey: with: indices contents with: home with: wasTypedKey!
Item was added:
+ ----- Method: TextEditor>>align (in category 'menu messages') -----
+ align
+ "Align text according to the next greater alignment value,
+ cycling among leftFlush, rightFlush, center, and justified."
+ self changeAlignment.
+ self recomputeSelection!
Item was added:
+ ----- Method: TextEditor>>align: (in category 'editing keys') -----
+ align: aKeyboardEvent
+ "Triggered by Cmd-u; cycle through alignment alternatives. 8/11/96 sw"
+
+ self align.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>applyAttribute: (in category 'private') -----
+ applyAttribute: aTextAttribute
+ "The user selected aTextAttribute via shortcut, menu or other means.
+ If there is a selection, apply the attribute to the selection.
+ In any case use the attribute for the user input (emphasisHere)"
+ | interval |
+
+ emphasisHere := Text addAttribute: aTextAttribute toArray: emphasisHere.
+
+ interval := self selectionInterval.
+ (interval isEmpty and: [ aTextAttribute isParagraphAttribute not ])
+ ifTrue: [ ^self ].
+
+ self text addAttribute: aTextAttribute from: interval first to: interval last.
+ paragraph recomposeFrom: interval first to: interval last delta: 0.
+ self recomputeSelection. "Needed so visible selection is updated to reflect new visual extent of selection"
+ morph changed!
Item was added:
+ ----- Method: TextEditor>>argAdvance: (in category 'typing/selecting keys') -----
+ argAdvance: aKeyboardEvent
+ "Invoked by Ctrl-a or Shift+Command+A. Useful after Ctrl-q.
+ Search forward from the end of the selection for a colon and place the caret after it. If no colon is found, do nothing."
+ | start |
+ self insertAndCloseTypeIn.
+ start := paragraph text
+ findString: ':'
+ startingAt: self stopIndex.
+ start isZero ifFalse: [ self selectAt: start + 1 ].
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>backTo: (in category 'typing support') -----
+ backTo: startIndex
+ "During typing, backspace to startIndex. Deleted characters fall into three
+ clusters, from left to right in the text: (1) preexisting characters that were
+ backed over; (2) newly typed characters that were backed over;
+ (3) preexisting characters that
+ were highlighted before typing began. If typing has not yet been opened,
+ open it and watch for the first and third cluster. If typing has been opened,
+ watch for the first and second cluster. Save characters from the first and third
+ cluster in UndoSelection. Tally characters from the first cluster in UndoMessage's parameter.
+ Delete all the clusters. Do not alter Undoer or UndoInterval (except via
+ openTypeIn). The code is shorter than the comment."
+
+ | saveLimit newBackovers |
+ saveLimit := beginTypeInIndex
+ ifNil: [self openTypeIn. UndoSelection := self nullText. self stopIndex].
+ markBlock := paragraph characterBlockForIndex: startIndex.
+ startIndex < saveLimit ifTrue: [
+ newBackovers := beginTypeInIndex - startIndex.
+ beginTypeInIndex := self startIndex.
+ UndoSelection replaceFrom: 1 to: 0 with:
+ (self text copyFrom: startIndex to: saveLimit - 1).
+ UndoMessage arguments size > 0 ifTrue: [
+ UndoMessage argument: (UndoMessage argument ifNil: [1]) + newBackovers]].
+ self zapSelectionWith: self nullText.
+ self unselect!
Item was added:
+ ----- Method: TextEditor>>beginningOfLine: (in category 'private') -----
+ beginningOfLine: position
+ "Redefined in subclasses using Paragraph support"
+ ^ (paragraph lines at:(paragraph lineIndexFor: position)) first!
Item was added:
+ ----- Method: TextEditor>>bindingOf: (in category 'binding') -----
+ bindingOf: aString
+ ^model bindingOf: aString!
Item was added:
+ ----- Method: TextEditor>>blinkParen (in category 'parenblinking') -----
+ blinkParen
+ "Used if Shout"
+ lastParenLocation ifNotNil: [
+ self text string size >= lastParenLocation ifTrue: [
+ self text
+ addAttribute: TextEmphasis bold
+ from: lastParenLocation
+ to: lastParenLocation]]!
Item was added:
+ ----- Method: TextEditor>>blinkParenAt: (in category 'parenblinking') -----
+ blinkParenAt: parenLocation
+ self text
+ addAttribute: TextEmphasis bold
+ from: parenLocation
+ to: parenLocation.
+ lastParenLocation := parenLocation.!
Item was added:
+ ----- Method: TextEditor>>blinkPrevParen: (in category 'parenblinking') -----
+ blinkPrevParen: aCharacter
+ "Used if not Shout"
+ | openDelimiter closeDelimiter level string here hereChar |
+ string := paragraph string.
+ here := pointBlock stringIndex.
+ openDelimiter := aCharacter.
+ closeDelimiter := '([{' at: (')]}' indexOf: openDelimiter).
+ level := 1.
+ [level > 0 and: [here > 1]]
+ whileTrue:
+ [hereChar := string at: (here := here - 1).
+ hereChar = closeDelimiter
+ ifTrue:
+ [level := level - 1.
+ level = 0
+ ifTrue: [^ self blinkParenAt: here]]
+ ifFalse:
+ [hereChar = openDelimiter
+ ifTrue: [level := level + 1]]]!
Item was added:
+ ----- Method: TextEditor>>browseChangeSetsWithSelector (in category 'menu messages') -----
+ browseChangeSetsWithSelector
+ "Determine which, if any, change sets have at least one change for the selected selector, independent of class"
+
+ | aSelector |
+ self lineSelectAndEmptyCheck: [^ self].
+ (aSelector := self selectedSelector) == nil ifTrue: [^ morph flash].
+ ChangeSorter browseChangeSetsWithSelector: aSelector!
Item was added:
+ ----- Method: TextEditor>>browseClassFromIt (in category 'menu messages') -----
+ browseClassFromIt
+ "Launch a hierarchy browser for the class indicated by the current selection. If multiple classes matching the selection exist, let the user choose among them."
+ | aClass |
+ self lineSelectAndEmptyCheck: [ ^ self ].
+ aClass := UIManager default
+ classFromPattern: self selection string withBlanksTrimmed
+ withCaption: 'choose a class to browse...'.
+ aClass ifNil: [ ^ morph flash ].
+ SystemNavigation default
+ spawnHierarchyForClass: aClass
+ selector: nil!
Item was added:
+ ----- Method: TextEditor>>browseIt (in category 'menu messages') -----
+ browseIt
+ "Launch a browser for the current selection, if appropriate"
+
+ | aSymbol anEntry brow |
+
+ Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt].
+
+ self lineSelectAndEmptyCheck: [^ self].
+ (aSymbol := self selectedSymbol) isNil ifTrue: [^ morph flash].
+
+ aSymbol first isUppercase
+ ifTrue:
+ [anEntry := (Smalltalk
+ at: aSymbol
+ ifAbsent:
+ [ self systemNavigation browseAllImplementorsOf: aSymbol.
+ ^ nil]).
+ anEntry ifNil: [^ morph flash].
+ (anEntry isKindOf: Class)
+ ifFalse: [anEntry := anEntry class].
+ brow := SystemBrowser default new.
+ brow setClass: anEntry selector: nil.
+ brow class
+ openBrowserView: (brow openEditString: nil)
+ label: 'System Browser']
+ ifFalse:
+ [self systemNavigation browseAllImplementorsOf: aSymbol]!
Item was added:
+ ----- Method: TextEditor>>browseIt: (in category 'editing keys') -----
+ browseIt: aKeyboardEvent
+ "Triggered by Cmd-B; browse the thing represented by the current selection, if plausible. 1/18/96 sw"
+
+ self browseIt.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>browseItHere (in category 'menu messages') -----
+ browseItHere
+ "Retarget the receiver's window to look at the selected class, if appropriate. 3/1/96 sw"
+ | aSymbol foundClass b |
+ (((b := model) isKindOf: Browser) and: [b couldBrowseAnyClass])
+ ifFalse: [^ morph flash].
+ model okToChange ifFalse: [^ morph flash].
+ self selectionInterval isEmpty ifTrue: [self selectWord].
+ (aSymbol := self selectedSymbol) isNil ifTrue: [^ morph flash].
+
+ foundClass := (Smalltalk at: aSymbol ifAbsent: [nil]).
+ foundClass isNil ifTrue: [^ morph flash].
+ (foundClass isKindOf: Class)
+ ifTrue:
+ [model selectSystemCategory: foundClass category.
+ model classListIndex: (model classList indexOf: foundClass name)]!
Item was added:
+ ----- Method: TextEditor>>browseItHere: (in category 'editing keys') -----
+ browseItHere: aKeyboardEvent
+ "Triggered by Cmd-shift-B; browse the thing represented by the current selection, if plausible, in the receiver's own window. 3/1/96 sw"
+
+ self browseItHere.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>cancel (in category 'menu messages') -----
+ cancel
+ "Cancel the changes made so far to this text"
+ morph cancelEdits!
Item was added:
+ ----- Method: TextEditor>>cancel: (in category 'editing keys') -----
+ cancel: aKeyboardEvent
+ "Cancel unsubmitted changes."
+
+ self cancel.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>changeAlignment (in category 'menu messages') -----
+ changeAlignment
+ | aList reply |
+ aList := #(leftFlush centered justified rightFlush).
+ reply := UIManager default chooseFrom: aList values: aList.
+ reply ifNil:[^self].
+ self setAlignment: reply.
+ paragraph composeAll.
+ self recomputeSelection.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>changeEmphasis: (in category 'editing keys') -----
+ changeEmphasis: aKeyboardEvent
+ "Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change. Keeps typeahead."
+
+ "control 0..9 -> 0..9"
+
+ | keyCode attribute oldAttributes index thisSel colors extras |
+ keyCode := ('0123456789-=' indexOf: aKeyboardEvent keyCharacter ifAbsent: [1]) - 1.
+ oldAttributes := paragraph text attributesAt: self pointIndex.
+ thisSel := self selection.
+
+ "Decipher keyCodes for Command 0-9..."
+ (keyCode between: 1 and: 5)
+ ifTrue: [attribute := TextFontChange fontNumber: keyCode].
+
+ keyCode = 6
+ ifTrue: [
+ colors := #(#black #magenta #red #yellow #green #blue #cyan #white).
+ extras := self emphasisExtras.
+ index := UIManager default chooseFrom:colors , #('choose color...' ), extras
+ lines: (Array with: colors size + 1).
+ index = 0 ifTrue: [^true].
+ index <= colors size
+ ifTrue: [attribute := TextColor color: (Color perform: (colors at: index))]
+ ifFalse: [
+ index := index - colors size - 1. "Re-number!!!!!!"
+ index = 0
+ ifTrue: [attribute := self chooseColor]
+ ifFalse:[^self handleEmphasisExtra: index with: aKeyboardEvent] "handle an extra"]].
+ (keyCode between: 7 and: 11)
+ ifTrue: [
+ aKeyboardEvent shiftPressed
+ ifTrue: [
+ keyCode = 10 ifTrue: [attribute := TextKern kern: -1].
+ keyCode = 11 ifTrue: [attribute := TextKern kern: 1]]
+ ifFalse: [
+ attribute := TextEmphasis
+ perform: (#(#bold #italic #narrow #underlined #struckOut) at: keyCode - 6).
+ oldAttributes
+ do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]].
+ keyCode = 0 ifTrue: [attribute := TextEmphasis normal].
+ attribute ifNotNil: [
+ thisSel size = 0
+ ifTrue: [
+ "only change emphasisHere while typing"
+ self insertTypeAhead.
+ emphasisHere := Text addAttribute: attribute toArray: oldAttributes ]
+ ifFalse: [
+ self replaceSelectionWith: (thisSel asText addAttribute: attribute) ]].
+ ^true!
Item was added:
+ ----- Method: TextEditor>>changeEmphasisOrAlignment (in category 'attributes') -----
+ changeEmphasisOrAlignment
+ | aList reply code align menuList startIndex |
+ startIndex := self startIndex.
+ aList := #(normal bold italic narrow underlined struckOut leftFlush centered rightFlush justified).
+ align := paragraph text alignmentAt: startIndex
+ ifAbsent: [ paragraph textStyle alignment ].
+ code := paragraph text emphasisAt: startIndex.
+ menuList := WriteStream on: Array new.
+ menuList nextPut: (code isZero ifTrue:['<on>'] ifFalse:['<off>']), 'normal' translated.
+ menuList nextPutAll: (#(bold italic underlined struckOut) collect:[:emph|
+ (code anyMask: (TextEmphasis perform: emph) emphasisCode)
+ ifTrue: [ '<on>', emph asString translated ]
+ ifFalse: [ '<off>',emph asString translated ]]).
+ ((paragraph text attributesAt: startIndex)
+ anySatisfy: [ :attr | attr isKern and: [attr kern < 0 ]])
+ ifTrue: [ menuList nextPut:'<on>', 'narrow' translated ]
+ ifFalse: [ menuList nextPut:'<off>', 'narrow' translated ].
+ menuList nextPutAll: (#(leftFlush centered rightFlush justified) collectWithIndex: [ :type :i |
+ align = (i-1)
+ ifTrue: [ '<on>',type asString translated ]
+ ifFalse: [ '<off>',type asString translated ]]).
+ aList := #(normal bold italic underlined struckOut narrow leftFlush centered rightFlush justified).
+ reply := UIManager default chooseFrom: menuList contents values: aList lines: #(1 6).
+ reply notNil ifTrue: [
+ (#(leftFlush centered rightFlush justified) includes: reply)
+ ifTrue: [
+ self setAlignment: reply.
+ paragraph composeAll.
+ self recomputeSelection]
+ ifFalse: [
+ self setEmphasis: reply.
+ paragraph composeAll.
+ self recomputeSelection]].
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>changeLfToCr: (in category 'editing keys') -----
+ changeLfToCr: aKeyboardEvent
+ "Replace all LFs by CRs.
+ Triggered by Cmd-U -- useful when getting code from FTP sites
+ jmv- Modified to als change crlf by cr"
+
+ | fixed |
+ fixed := self selection string withSqueakLineEndings.
+ self replaceSelectionWith: (Text fromString: fixed).
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>changeParagraph: (in category 'initialize-release') -----
+ changeParagraph: aParagraph
+ "Install aParagraph as the one to be edited by the receiver."
+
+ UndoParagraph == paragraph ifTrue: [UndoParagraph := nil].
+ paragraph := aParagraph.
+ self resetState!
Item was added:
+ ----- Method: TextEditor>>changeSelectionFontTo: (in category 'attributes') -----
+ changeSelectionFontTo: aFont
+ | attr |
+ aFont ifNil: [ ^ self ].
+ attr := TextFontReference toFont: aFont.
+ paragraph text
+ addAttribute: attr
+ from: self startIndex
+ to:
+ (self hasSelection
+ ifTrue: [ self stopIndex - 1 min: paragraph text size ]
+ ifFalse: [ paragraph text size ]).
+ paragraph composeAll.
+ self recomputeSelection.
+ morph changed!
Item was added:
+ ----- Method: TextEditor>>changeStyle (in category 'attributes') -----
+ changeStyle
+ "Let user change styles for the current text pane."
+ | names reply style current menuList |
+
+ current := paragraph textStyle.
+ names := TextStyle knownTextStyles.
+ menuList := names collect: [ :styleName |
+ styleName = current name
+ ifTrue: [ '<on>', styleName ]
+ ifFalse: [ '<off>', styleName ]].
+ reply := UIManager default chooseFrom: menuList values: names.
+ reply ifNotNil: [
+ (style := TextStyle named: reply) ifNil: [Beeper beep. ^ true].
+ paragraph textStyle: style.
+ paragraph composeAll.
+ self recomputeSelection].
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>changeStyle: (in category 'typing/selecting keys') -----
+ changeStyle: aKeyboardEvent
+ "Put up the style-change menu"
+
+ self insertAndCloseTypeIn.
+ self changeStyle.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>changeTextFont (in category 'attributes') -----
+ changeTextFont
+ "Present a dialog which allows the user to select a font, and if one is chosen, apply it to the current selection. If there is no selection, or the selection is empty, apply it to the whole morph."
+ | curFont startIndex |
+ startIndex := self startIndex.
+ curFont := (paragraph text fontAt: startIndex withStyle: paragraph textStyle).
+ morph openModal: (
+ Cursor wait showWhile: [
+ (FontChooserTool default
+ withTitle: 'Change the selected text''s font to...' translated
+ for: self
+ setSelector: #changeSelectionFontTo:
+ getSelector: curFont)
+ "Do not allow changing the emphasis; we don't know how to deal with
+ a 'pre-emphasized' font here, so bail."
+ offerStyleList: false;
+ open])!
Item was added:
+ ----- Method: TextEditor>>chooseAlignment (in category 'menu messages') -----
+ chooseAlignment
+ self changeAlignment!
Item was added:
+ ----- Method: TextEditor>>chooseColor (in category 'editing keys') -----
+ chooseColor
+ "Make a new Text Color Attribute, let the user pick a color, and return the attribute"
+ | attribute |
+ attribute := TextColor color: Color black.
+ NewColorPickerMorph useIt
+ ifTrue:
+ [ (NewColorPickerMorph on: attribute) openNear: morph fullBoundsInWorld ]
+ ifFalse:
+ [ ColorPickerMorph new
+ choseModalityFromPreference ;
+ sourceHand: morph activeHand ;
+ target: attribute ;
+ selector: #color: ;
+ originalColor: Color black ;
+
+ putUpFor: morph
+ near: morph fullBoundsInWorld ].
+ ^ attribute!
Item was added:
+ ----- Method: TextEditor>>classCommentsContainingIt (in category 'menu messages') -----
+ classCommentsContainingIt
+ "Open a browser class comments which contain the current selection somewhere in them."
+
+ self lineSelectAndEmptyCheck: [^ self].
+ self systemNavigation browseClassCommentsWithString: self selection string!
Item was added:
+ ----- Method: TextEditor>>classNamesContainingIt (in category 'menu messages') -----
+ classNamesContainingIt
+ "Open a browser on classes whose names contain the selected string"
+
+ self lineSelectAndEmptyCheck: [^self].
+ self systemNavigation
+ browseClassesWithNamesContaining: self selection string
+ caseSensitive: Sensor leftShiftDown!
Item was added:
+ ----- Method: TextEditor>>clearParens (in category 'parenblinking') -----
+ clearParens
+ lastParenLocation ifNotNil: [
+ self text string size >= lastParenLocation ifTrue: [
+ self text
+ removeAttribute: TextEmphasis bold
+ from: lastParenLocation
+ to: lastParenLocation]].
+ lastParenLocation := nil!
Item was added:
+ ----- Method: TextEditor>>closeTypeIn (in category 'typing support') -----
+ closeTypeIn
+ "See comment in openTypeIn. It is important to call closeTypeIn before executing
+ any non-typing key, making a new selection, etc. It is called automatically for
+ menu commands.
+ Undoer & Redoer: undoAndReselect:redoAndReselect:."
+
+ | begin stop |
+ beginTypeInIndex ifNotNil: [
+ (UndoMessage sends: #noUndoer) ifTrue: [ "should always be true, but just in case..."
+ begin := beginTypeInIndex.
+ stop := self stopIndex.
+ self undoer: #undoAndReselect:redoAndReselect:
+ with: (begin + UndoMessage argument to: begin + UndoSelection size - 1)
+ with: (stop to: stop - 1).
+ UndoInterval := begin to: stop - 1].
+ beginTypeInIndex := nil]!
Item was added:
+ ----- Method: TextEditor>>compareToClipboard (in category 'menu messages') -----
+ compareToClipboard
+ "If any text is selected, present the modifications that would be made to it if the clipboard contents were pasted over it. If no text is selected, present the differences betwen the entire pane's contents and the clipboard text."
+ | subjectText proposedText |
+ subjectText := self selection string ifEmpty: [ paragraph text string ].
+ proposedText := self clipboardText string.
+ subjectText = proposedText ifTrue: [^ self inform: 'Exact match'].
+ (StringHolder new
+ textContents:
+ (TextDiffBuilder
+ buildDisplayPatchFrom: subjectText
+ to: proposedText)) openLabel: 'Differences with Clipboard Text'!
Item was added:
+ ----- Method: TextEditor>>compareToClipboard: (in category 'editing keys') -----
+ compareToClipboard: aKeyboardEvent
+ "Compare the receiver to the text on the clipboard."
+
+ self compareToClipboard.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>compileSelectionFor:in: (in category 'do-its') -----
+ compileSelectionFor: anObject in: evalContext
+
+ | methodNode |
+ methodNode := [Compiler new
+ compileNoPattern: self selectionAsStream
+ in: anObject class
+ context: evalContext
+ notifying: self
+ ifFail: [^nil]]
+ on: OutOfScopeNotification
+ do: [:ex | ex resume: true].
+ ^ methodNode generateWithTempNames!
Item was added:
+ ----- Method: TextEditor>>completeSymbol:lastOffering: (in category 'private') -----
+ completeSymbol: hintText lastOffering: selectorOrNil
+ "Invoked by Ctrl-q when there is only a caret.
+ Do selector-completion, i.e., try to replace the preceding identifier by a
+ selector that begins with those characters & has as many keywords as possible.
+ Leave two spaces after each colon (only one after the last) as space for
+ arguments. Put the caret after the space after the first keyword. If the
+ user types Ctrl-q again immediately, choose a different selector.
+ Undoer: #undoQuery:lastOffering:; Redoer: itself.
+ If redoing, just redisplay the last offering, selector[OrNil]."
+
+ | firstTime input prior caret newStart sym kwds outStream |
+ firstTime := self isRedoing
+ ifTrue: [prior := sym := selectorOrNil. true]
+ ifFalse: [hintText isNil].
+ firstTime
+ ifTrue: "Initial Ctrl-q (or redo)"
+ [caret := self startIndex.
+ self selectPrecedingIdentifier.
+ input := self selection]
+ ifFalse: "Repeated Ctrl-q"
+ [caret := UndoInterval first + hintText size.
+ self selectInvisiblyFrom: UndoInterval first to: UndoInterval last.
+ input := hintText.
+ prior := selectorOrNil].
+ (input size ~= 0 and: [sym ~~ nil or:
+ [(sym := Symbol thatStarts: input string skipping: prior) ~~ nil]])
+ ifTrue: "found something to offer"
+ [newStart := self startIndex.
+ outStream := WriteStream on: (String new: 2 * sym size).
+ 1 to: (kwds := sym keywords) size do:
+ [:i |
+ outStream nextPutAll: (kwds at: i).
+ i = 1 ifTrue: [caret := newStart + outStream contents size + 1].
+ outStream nextPutAll:
+ (i < kwds size ifTrue: [' '] ifFalse: [' '])].
+ UndoSelection := input.
+ self deselect; zapSelectionWith: outStream contents asText.
+ self undoer: #undoQuery:lastOffering: with: input with: sym]
+ ifFalse: "no more matches"
+ [firstTime ifFalse: "restore original text & set up for a redo"
+ [UndoSelection := self selection.
+ self deselect; zapSelectionWith: input.
+ self undoer: #completeSymbol:lastOffering: with: input with: prior.
+ Undone := true].
+ morph flash].
+ self selectAt: caret!
Item was added:
+ ----- Method: TextEditor>>copyHiddenInfo (in category 'editing keys') -----
+ copyHiddenInfo
+ "In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden
+ info. Copy that to the clipboard. You can paste it and see what it is.
+ Usually enclosed in <>."
+
+ ^ self clipboardTextPut: self hiddenInfo!
Item was added:
+ ----- Method: TextEditor>>copySelection (in category 'menu messages') -----
+ copySelection
+ "Copy the current selection and store it in the paste buffer, unless a caret. Undoer & Redoer: undoCutCopy"
+
+ self lineSelectAndEmptyCheck: [^ self].
+
+ "Simulate 'substitute: self selection' without locking the controller"
+ UndoSelection := self selection.
+ self undoer: #undoCutCopy: with: self clipboardText.
+ UndoInterval := self selectionInterval.
+ self clipboardTextPut: UndoSelection!
Item was added:
+ ----- Method: TextEditor>>correctFrom:to:with: (in category 'new selection') -----
+ correctFrom: start to: stop with: aString
+ "Make a correction in the model that the user has authorised from somewhere else in the system (such as from the compilier). The user's selection is not changed, only corrected."
+ | userSelection delta loc wasShowing |
+ aString = '#insert period' ifTrue: [
+ loc := start.
+ [(loc := loc-1)>0 and: [(paragraph string at: loc) isSeparator]]
+ whileTrue: [loc := loc-1].
+ ^ self correctFrom: loc+1 to: loc with: '.'].
+ (wasShowing := selectionShowing) ifTrue: [ self reverseSelection ].
+ userSelection := self selectionInterval.
+
+ self selectInvisiblyFrom: start to: stop.
+ self replaceSelectionWith: aString.
+
+ delta := aString size - (stop - start + 1).
+ self
+ selectInvisiblyFrom: userSelection first + (userSelection first > start ifFalse: [ 0 ] ifTrue: [ delta ])
+ to: userSelection last + (userSelection last > start ifFalse: [ 0 ] ifTrue: [ delta ]).
+ wasShowing ifTrue: [ self reverseSelection ].
+ !
Item was added:
+ ----- Method: TextEditor>>crWithIndent: (in category 'typing/selecting keys') -----
+ crWithIndent: aKeyboardEvent
+ "Replace the current text selection with CR followed by as many tabs
+ as on the current line (+/- bracket count) -- initiated by Shift-Return."
+ self addString: (String streamContents: [:characterStream | characterStream crtab: self tabCount]). "Now inject CR with tabCount tabs"
+ ^ false!
Item was added:
+ ----- Method: TextEditor>>cursorEnd: (in category 'nonediting/nontyping keys') -----
+ cursorEnd: aKeyboardEvent
+
+ "Private - Move cursor end of current line."
+ | string |
+ self insertAndCloseTypeIn.
+ string := paragraph text string.
+ self
+ moveCursor:
+ [:position | Preferences wordStyleCursorMovement
+ ifTrue:[| targetLine |
+ targetLine := paragraph lines at:(paragraph lineIndexOfCharacterIndex: position).
+ targetLine = paragraph lastLine
+ ifTrue:[targetLine last + 1]
+ ifFalse:[targetLine last]]
+ ifFalse:[
+ string
+ indexOfAnyOf: CharacterSet crlf
+ startingAt: position
+ ifAbsent:[string size + 1]]]
+ forward: true
+ event: aKeyboardEvent
+ specialBlock:[:dummy | string size + 1].
+ ^true!
Item was added:
+ ----- Method: TextEditor>>cursorHome: (in category 'nonediting/nontyping keys') -----
+ cursorHome: aKeyboardEvent
+
+ "Private - Move cursor from position in current line to beginning of
+ current line. If control key is pressed put cursor at beginning of text"
+
+ | string |
+
+ string := paragraph text string.
+ self
+ moveCursor: [ :position | Preferences wordStyleCursorMovement
+ ifTrue:[
+ (paragraph lines at:(paragraph lineIndexOfCharacterIndex: position)) first]
+ ifFalse:[
+ (string
+ lastIndexOfAnyOf: CharacterSet crlf
+ startingAt: position - 1
+ ifAbsent:[0]) + 1]]
+ forward: false
+ event: aKeyboardEvent
+ specialBlock: [:dummy | 1].
+ ^true!
Item was added:
+ ----- Method: TextEditor>>cut (in category 'menu messages') -----
+ cut
+ "Cut out the current selection and redisplay the paragraph if necessary. Undoer & Redoer: undoCutCopy:"
+
+ self lineSelectAndEmptyCheck: [^ self].
+
+ self replaceSelectionWith: self nullText.
+ self undoer: #undoCutCopy: with: self clipboardText.
+ self clipboardTextPut: UndoSelection!
Item was added:
+ ----- Method: TextEditor>>debug:receiver:in: (in category 'do-its') -----
+ debug: aCompiledMethod receiver: anObject in: evalContext
+
+ | guineaPig debugger debuggerWindow context |
+ guineaPig :=
+ [aCompiledMethod
+ valueWithReceiver: anObject
+ arguments: (evalContext ifNil: [ #() ] ifNotNil: [ { evalContext } ]).
+ guineaPig := nil "spot the return from aCompiledMethod"] newProcess.
+ context := guineaPig suspendedContext.
+ debugger := Debugger new
+ process: guineaPig
+ controller: nil
+ context: context.
+ debuggerWindow := debugger openFullNoSuspendLabel: 'Debug it'.
+ "Now step into the expression. But if it is quick (is implemented as a primtiive, e.g. `0')
+ it will return immediately back to the block that is sent newProcess above. Guard
+ against that with the check for home being thisContext."
+ [debugger interruptedContext method == aCompiledMethod]
+ whileFalse:
+ [(guineaPig isNil
+ and: [debugger interruptedContext home == thisContext]) ifTrue:
+ [debuggerWindow delete.
+ UIManager default inform: 'Nothing to debug; expression is optimized'.
+ ^self].
+ debugger send]!
Item was added:
+ ----- Method: TextEditor>>debugIt (in category 'do-its') -----
+ debugIt
+
+ | method receiver context |
+ (model respondsTo: #doItReceiver)
+ ifTrue:
+ [receiver := model doItReceiver.
+ context := model doItContext]
+ ifFalse:
+ [receiver := context := nil].
+ self lineSelectAndEmptyCheck: [^self].
+ method := self compileSelectionFor: receiver in: context.
+ method notNil ifTrue:
+ [self debug: method receiver: receiver in: context].!
Item was added:
+ ----- Method: TextEditor>>destructiveBackWord: (in category 'typing/selecting keys') -----
+ destructiveBackWord: aKeyboardEvent
+ typeAhead isEmpty
+ ifTrue: [ super destructiveBackWord: aKeyboardEvent ]
+ ifFalse: [ typeAhead reset ].
+ ^ false!
Item was added:
+ ----- Method: TextEditor>>dispatchOnEnterWith: (in category 'typing support') -----
+ dispatchOnEnterWith: aKeyboardEvent
+ "Enter key hit. Treat is as an 'accept', viz a synonym for cmd-s. If cmd key is down, treat is as a synonym for print-it. "
+
+ aKeyboardEvent commandKeyPressed
+ ifTrue:
+ [self printIt.]
+ ifFalse:
+ [self insertAndCloseTypeIn.
+ self accept].
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>dispatchOnKeyboardEvent: (in category 'typing support') -----
+ dispatchOnKeyboardEvent: aKeyboardEvent
+ "Carry out the action associated with this character, if any.
+ Type-ahead is passed so some routines can flush or use it."
+
+ | honorCommandKeys openers closers result |
+ (aKeyboardEvent keyCharacter == Character cr and: [ morph acceptOnCR ])
+ ifTrue: [
+ self closeTypeIn.
+ ^ true ].
+ self clearParens.
+ aKeyboardEvent keyValue = 13
+ ifTrue: [
+ aKeyboardEvent controlKeyPressed
+ ifTrue: [ ^ self normalCharacter: aKeyboardEvent ].
+ aKeyboardEvent shiftPressed
+ ifTrue: [ ^ self lf: aKeyboardEvent ].
+ aKeyboardEvent commandKeyPressed
+ ifTrue: [ ^ self crlf: aKeyboardEvent ].
+ ^ self crWithIndent: aKeyboardEvent ].
+ ((honorCommandKeys := Preferences cmdKeysInText) and: [ aKeyboardEvent keyCharacter = Character enter ])
+ ifTrue: [ ^ self dispatchOnEnterWith: aKeyboardEvent ]. "Special keys overwrite crtl+key combinations - at least on Windows. To resolve this
+ conflict, assume that keys other than cursor keys aren't used together with Crtl."
+ ((self class specialShiftCmdKeys includes: aKeyboardEvent keyValue) and: [ aKeyboardEvent keyValue < 27 ])
+ ifTrue: [
+ ^ aKeyboardEvent controlKeyPressed
+ ifTrue: [ self perform: (self class shiftCmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent ]
+ ifFalse: [ self perform: (self class cmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent ] ]. "backspace, and escape keys (ascii 8 and 27) are command keys"
+ ((honorCommandKeys and: [ aKeyboardEvent commandKeyPressed ])
+ or: [ self class specialShiftCmdKeys includes: aKeyboardEvent keyValue ])
+ ifTrue: [
+ ^ aKeyboardEvent shiftPressed
+ ifTrue: [ self perform: (self class shiftCmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent ]
+ ifFalse: [ self perform: (self class cmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent ] ]. "the control key can be used to invoke shift-cmd shortcuts"
+ (honorCommandKeys and: [ aKeyboardEvent controlKeyPressed ])
+ ifTrue: [ ^ self perform: (self class shiftCmdActions at: aKeyboardEvent keyValue + 1) with: aKeyboardEvent ].
+ openers := '([{'.
+ closers := ')]}'.
+ result := self normalCharacter: aKeyboardEvent.
+ (closers includes: aKeyboardEvent keyCharacter)
+ ifTrue: [ self blinkPrevParen: aKeyboardEvent keyCharacter].
+ (self class autoEnclose and: [ openers includes: aKeyboardEvent keyCharacter ])
+ ifTrue: [
+ self
+ addString: (closers at: (openers indexOf: aKeyboardEvent keyCharacter)) asString;
+ insertTypeAhead ;
+
+ moveCursor: [ :position | position - 1 ]
+ forward: false
+ select: false ].
+ ^ result!
Item was added:
+ ----- Method: TextEditor>>displayIfFalse: (in category 'typing/selecting keys') -----
+ displayIfFalse: aKeyboardEvent
+ "Replace the current text selection with the text 'ifFalse:'--initiated by
+ ctrl-f."
+
+ self addString: 'ifFalse:'.
+ ^false!
Item was added:
+ ----- Method: TextEditor>>displayIfTrue: (in category 'typing/selecting keys') -----
+ displayIfTrue: aKeyboardEvent
+ "Replace the current text selection with the text 'ifTrue:'--initiated by
+ ctrl-t."
+
+ self addString: 'ifTrue:'.
+ ^false!
Item was added:
+ ----- Method: TextEditor>>doAgainMany: (in category 'typing/selecting keys') -----
+ doAgainMany: aKeyboardEvent
+ "Do the previous thing again repeatedly. 1/26/96 sw"
+
+ self insertAndCloseTypeIn.
+ self againOrSame: (UndoMessage sends: #undoAgain:andReselect:typedKey:) many: true.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>doAgainOnce: (in category 'typing/selecting keys') -----
+ doAgainOnce: aKeyboardEvent
+ "Do the previous thing again once. 1/26/96 sw"
+
+ self insertAndCloseTypeIn.
+ self again.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>doIt (in category 'do-its') -----
+ doIt
+ "Set the context to include pool vars of the model. Then evaluate."
+ ^ self evaluateSelection!
Item was added:
+ ----- Method: TextEditor>>doIt: (in category 'editing keys') -----
+ doIt: aKeyboardEvent
+ "Called when user hits cmd-d. Select the current line, if relevant, then evaluate and execute. 2/1/96 sw.
+ 2/29/96 sw: don't call selectLine; it's done by doIt now"
+
+ self doIt.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>doneTyping (in category 'typing support') -----
+ doneTyping
+ beginTypeInIndex := nil!
Item was added:
+ ----- Method: TextEditor>>duplicate: (in category 'editing keys') -----
+ duplicate: aKeyboardEvent
+ "Paste the current selection over the prior selection, if it is non-overlapping and
+ legal. Flushes typeahead. Undoer & Redoer: undoAndReselect."
+
+ self closeTypeIn.
+ (self hasSelection and: [self isDisjointFrom: otherInterval])
+ ifTrue: "Something to duplicate"
+ [self replace: otherInterval with: self selection and:
+ [self selectAt: self pointIndex]]
+ ifFalse:
+ [morph flash].
+ ^true!
Item was added:
+ ----- Method: TextEditor>>emphasisExtras (in category 'editing keys') -----
+ emphasisExtras
+ "Answer an array of extra items for the emphasis menu"
+ ^#()!
Item was added:
+ ----- Method: TextEditor>>enclose: (in category 'editing keys') -----
+ enclose: aKeyboardEvent
+ "Insert or remove bracket characters around the current selection."
+
+ | character left right startIndex stopIndex oldSelection which t |
+ character := aKeyboardEvent shiftPressed
+ ifTrue: ['{}|"<>' at: ('[]\'',.' indexOf: aKeyboardEvent keyCharacter) ifAbsent: [aKeyboardEvent keyCharacter]]
+ ifFalse: [aKeyboardEvent keyCharacter].
+ self closeTypeIn.
+ startIndex := self startIndex.
+ stopIndex := self stopIndex.
+ oldSelection := self selection.
+ which := '([<{|"''9' indexOf: character ifAbsent: [ ^true ].
+ "Allow Control key in lieu of Alt+Shift for (, {, and double-quote."
+ left := ((Preferences cmdKeysInText and: [ aKeyboardEvent controlKeyPressed ])
+ ifTrue: [ '({<{|""(' ]
+ ifFalse: ['([<{|"''(']) at: which.
+ right := ((Preferences cmdKeysInText and: [ aKeyboardEvent controlKeyPressed ])
+ ifTrue: [ ')}>}|"")' ]
+ ifFalse: [')]>}|"'')']) at: which.
+ t := self text.
+ ((startIndex > 1 and: [stopIndex <= t size])
+ and: [ (t at: startIndex-1) = left and: [(t at: stopIndex) = right]])
+ ifTrue: [
+ "already enclosed; strip off brackets"
+ self selectFrom: startIndex-1 to: stopIndex.
+ self replaceSelectionWith: oldSelection]
+ ifFalse: [
+ "not enclosed; enclose by matching brackets"
+ self replaceSelectionWith:
+ (Text string: (String with: left), oldSelection string, (String with: right) attributes: emphasisHere).
+ self selectFrom: startIndex+1 to: stopIndex].
+ ^true!
Item was added:
+ ----- Method: TextEditor>>encompassLine: (in category 'new selection') -----
+ encompassLine: anInterval
+ "Return an interval that encompasses the entire line"
+ | string left right |
+ string := paragraph text string.
+ left := (string lastIndexOfAnyOf: CharacterSet crlf startingAt: anInterval first - 1 ifAbsent:[0]) + 1.
+ right := (string indexOfAnyOf: CharacterSet crlf startingAt: anInterval last + 1 ifAbsent: [string size + 1]) - 1.
+ ^left to: right!
Item was added:
+ ----- Method: TextEditor>>endOfLine: (in category 'private') -----
+ endOfLine: position
+ "Redefined in subclasses using Paragraph support"
+ | targetLine |
+ targetLine := paragraph lines at: (paragraph lineIndexFor: position).
+ ^ targetLine = paragraph lastLine
+ ifFalse: [ targetLine last ]
+ ifTrue: [ targetLine last + 1 ]!
Item was added:
+ ----- Method: TextEditor>>evaluateSelection (in category 'do-its') -----
+ evaluateSelection
+ "Treat the current selection as an expression; evaluate it and return the result"
+
+ ^self evaluateSelectionAndDo: [:result | result]!
Item was added:
+ ----- Method: TextEditor>>evaluateSelectionAndDo: (in category 'do-its') -----
+ evaluateSelectionAndDo: aBlock
+ "Treat the current selection as an expression; evaluate it and invoke aBlock with the result."
+ | result rcvr ctxt |
+ self lineSelectAndEmptyCheck: [^ nil].
+
+ (model respondsTo: #doItReceiver)
+ ifTrue: [ rcvr := model doItReceiver.
+ ctxt := model doItContext]
+ ifFalse: [rcvr := ctxt := nil].
+ result := [
+ rcvr class evaluatorClass new
+ evaluate: self selectionAsStream
+ in: ctxt
+ to: rcvr
+ notifying: self
+ ifFail: [morph flash. ^ nil]
+ logged: true.
+ ]
+ on: OutOfScopeNotification
+ do: [ :ex | ex resume: true].
+
+ (model respondsTo: #evaluated:result:) ifTrue: [
+ model perform: #evaluated:result: with: self selection with: result].
+
+ ^aBlock value: result!
Item was added:
+ ----- Method: TextEditor>>exchange (in category 'menu messages') -----
+ exchange
+ "See comment in exchangeWith:"
+
+ self exchangeWith: otherInterval!
Item was added:
+ ----- Method: TextEditor>>exchange: (in category 'editing keys') -----
+ exchange: eKeyboardEvent
+ "Exchange the current and prior selections. Keeps typeahead."
+
+ self insertAndCloseTypeIn.
+ self exchange.
+ ^true!
Item was added:
+ ----- Method: TextEditor>>exchangeWith: (in category 'private') -----
+ exchangeWith: prior
+ "If the prior selection is non-overlapping and legal, exchange the text of
+ it with the current selection and leave the currently selected text selected
+ in the location of the prior selection (or leave a caret after a non-caret if it was
+ exchanged with a caret). If both selections are carets, flash & do nothing.
+ Don't affect the paste buffer. Undoer: itself; Redoer: Undoer."
+
+ | start stop before selection priorSelection delta altInterval |
+ start := self startIndex.
+ stop := self stopIndex - 1.
+ ((prior first <= prior last) | (start <= stop) "Something to exchange" and:
+ [self isDisjointFrom: prior])
+ ifTrue:
+ [before := prior last < start.
+ selection := self selection.
+ priorSelection := paragraph text copyFrom: prior first to: prior last.
+
+ delta := before ifTrue: [0] ifFalse: [priorSelection size - selection size].
+ self zapSelectionWith: priorSelection.
+ self selectFrom: prior first + delta to: prior last + delta.
+
+ delta := before ifTrue: [stop - prior last] ifFalse: [start - prior first].
+ self zapSelectionWith: selection.
+ altInterval := prior first + delta to: prior last + delta.
+ self undoer: #exchangeWith: with: altInterval.
+ "If one was a caret, make it otherInterval & leave the caret after the other"
+ prior first > prior last ifTrue: [self selectAt: UndoInterval last + 1].
+ otherInterval := start > stop
+ ifTrue: [self selectAt: altInterval last + 1. UndoInterval]
+ ifFalse: [altInterval]]
+ ifFalse:
+ [morph flash]!
Item was added:
+ ----- Method: TextEditor>>explain (in category 'menu messages') -----
+ explain
+ "Try to shed some light on what kind of entity the current selection is.
+ The selection must be a single token or construct. Insert the answer after
+ the selection. Send private messages whose names begin with 'explain'
+ that return a string if they recognize the selection, else nil."
+
+
+ Cursor execute showWhile:
+ [ | string numbers delimitors cgVars reply selectors tiVars symbol sorry |
+ sorry := '"Sorry, I can''t explain that. Please select a single
+ token, construct, or special character.'.
+ sorry := sorry , (morph canDiscardEdits
+ ifFalse: [' Also, please cancel or accept."']
+ ifTrue: ['"']).
+ (string := self selection asString) isEmpty
+ ifTrue: [reply := '']
+ ifFalse: [string := self explainScan: string.
+ "Remove space, tab, cr"
+ "Temps and Instance vars need only test strings that are all letters"
+ (string allSatisfy: [:char | char isLetter or: [char isDigit]])
+ ifTrue:
+ [tiVars := self explainTemp: string.
+ tiVars == nil ifTrue: [tiVars := self explainInst: string]].
+ (tiVars == nil and: [model respondsTo: #explainSpecial:])
+ ifTrue: [tiVars := model explainSpecial: string].
+ tiVars == nil
+ ifTrue: [tiVars := '']
+ ifFalse: [tiVars := tiVars , '\' withCRs].
+ "Context, Class, Pool, and Global vars, and Selectors need
+ only test symbols"
+ (Symbol hasInterned: string ifTrue: [:s | symbol := s])
+ ifTrue: [cgVars := self explainCtxt: symbol.
+ cgVars == nil
+ ifTrue: [cgVars := self explainClass: symbol.
+ cgVars == nil ifTrue: [cgVars := self explainGlobal: symbol]].
+ "See if it is a Selector (sent here or not)"
+ selectors := self explainMySel: symbol.
+ selectors == nil
+ ifTrue:
+ [selectors := self explainPartSel: string.
+ selectors == nil ifTrue: [
+ selectors := self explainAnySel: symbol]]]
+ ifFalse: [selectors := self explainPartSel: string].
+ cgVars == nil
+ ifTrue: [cgVars := '']
+ ifFalse: [cgVars := cgVars , '\' withCRs].
+ selectors == nil
+ ifTrue: [selectors := '']
+ ifFalse: [selectors := selectors , '\' withCRs].
+ string size = 1
+ ifTrue: ["single special characters"
+ delimitors := self explainChar: string]
+ ifFalse: ["matched delimitors"
+ delimitors := self explainDelimitor: string].
+ numbers := self explainNumber: string.
+ numbers == nil ifTrue: [numbers := ''].
+ delimitors == nil ifTrue: [delimitors := ''].
+ reply := tiVars , cgVars , selectors , delimitors , numbers].
+ reply size = 0 ifTrue: [reply := sorry].
+ self afterSelectionInsertAndSelect: reply]!
Item was added:
+ ----- Method: TextEditor>>explainAnySel: (in category 'explain') -----
+ explainAnySel: symbol
+ "Is this any message selector?"
+
+ | list reply |
+ list := self systemNavigation allClassesImplementing: symbol.
+ list size = 0 ifTrue: [^nil].
+ list size < 12
+ ifTrue: [reply := ' is a message selector which is defined in these classes ' , list printString]
+ ifFalse: [reply := ' is a message selector which is defined in many classes'].
+ ^'"' , symbol , reply , '."' , '\' withCRs, 'SystemNavigation new browseAllImplementorsOf: #' , symbol!
Item was added:
+ ----- Method: TextEditor>>explainChar: (in category 'explain') -----
+ explainChar: string
+ "Does string start with a special character?"
+
+ | char |
+ char := string at: 1.
+ char = $. ifTrue: [^'"Period marks the end of a Smalltalk statement. A period in the middle of a number means a decimal point. (The number is an instance of class Float)."'].
+ char = $' ifTrue: [^'"The characters between two single quotes are made into an instance of class String"'].
+ char = $" ifTrue: [^'"Double quotes enclose a comment. Smalltalk ignores everything between double quotes."'].
+ char = $# ifTrue: [^'"The characters following a hash mark are made into an instance of class Symbol. If parenthesis follow a hash mark, an instance of class Array is made. It contains literal constants."'].
+ (char = $( or: [char = $)]) ifTrue: [^'"Expressions enclosed in parenthesis are evaluated first"'].
+ (char = $[ or: [char = $]]) ifTrue: [^'"The code inside square brackets is an unevaluated block of code. It becomes an instance of BlockContext and is usually passed as an argument."'].
+ (char = ${ or: [char = $}]) ifTrue: [^ '"A sequence of expressions separated by periods, when enclosed in curly braces, are evaluated to yield the elements of a new Array"'].
+ (char = $< or: [char = $>]) ifTrue: [^'"<primitive: xx> means that this method is usually preformed directly by the virtual machine. If this method is primitive, its Smalltalk code is executed only when the primitive fails."'].
+ char = $^ ifTrue: [^'"Uparrow means return from this method. The value returned is the expression following the ^"'].
+ char = $| ifTrue: [^'"Vertical bars enclose the names of the temporary variables used in this method. In a block, the vertical bar separates the argument names from the rest of the code."'].
+ char = $_ ifTrue: [^'"Left arrow means assignment. The value of the expression after the left arrow is stored into the variable before it."'].
+ char = $; ifTrue: [^'"Semicolon means cascading. The message after the semicolon is sent to the same object which received the message before the semicolon."'].
+ char = $: ifTrue: [^'"A colon at the end of a keyword means that an argument is expected to follow. Methods which take more than one argument have selectors with more than one keyword. (One keyword, ending with a colon, appears before each argument).', '\\' withCRs, 'A colon before a variable name just inside a block means that the block takes an agrument. (When the block is evaluated, the argument will be assigned to the variable whose name appears after the colon)."'].
+ char = $$ ifTrue: [^'"The single character following a dollar sign is made into an instance of class Character"'].
+ char = $- ifTrue: [^'"A minus sign in front of a number means a negative number."'].
+ char = $e ifTrue: [^'"An e in the middle of a number means that the exponent follows."'].
+ char = $r ifTrue: [^'"An r in the middle of a bunch of digits is an instance of Integer expressed in a certain radix. The digits before the r denote the base and the digits after it express a number in that base."'].
+ char = Character space ifTrue: [^'"the space Character"'].
+ char = Character tab ifTrue: [^'"the tab Character"'].
+ char = Character cr ifTrue: [^'"the carriage return Character"'].
+ char = Character lf ifTrue: [^'"the line feed Character"'].
+ ^nil!
Item was added:
+ ----- Method: TextEditor>>explainClass: (in category 'explain') -----
+ explainClass: symbol
+ "Is symbol a class variable or a pool variable?"
+ | class reply classes |
+ (model respondsTo: #selectedClassOrMetaClass)
+ ifFalse: [^ nil].
+ (class := model selectedClassOrMetaClass) ifNil: [^ nil].
+ "no class is selected"
+ (class isKindOf: Metaclass)
+ ifTrue: [class := class soleInstance].
+ classes := class withAllSuperclasses.
+ "class variables"
+ reply := classes detect: [:each | each classVarNames anySatisfy: [:name | symbol = name]]
+ ifNone: [].
+ reply == nil ifFalse: [^ '"is a class variable, defined in class ' , reply printString , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (' , reply printString , ' classPool associationAt: #' , symbol , ').'].
+ "pool variables"
+ classes do: [:each | each sharedPools
+ anySatisfy: [:pool | (pool includesKey: symbol)
+ and:
+ [reply := pool.
+ true]]].
+ reply
+ ifNil: [(class environment isUndeclared: symbol)
+ ifTrue: [^ '"is an undeclared variable.' , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (Undeclared associationAt: #' , symbol , ').']]
+ ifNotNil:
+ [classes := WriteStream on: Array new.
+ self systemNavigation
+ allBehaviorsDo: [:each | (each sharedPools
+ detect:
+ [:pool |
+ pool == reply]
+ ifNone: [])
+ ~~ nil ifTrue: [classes nextPut: each]].
+ "Perhaps not print whole list of classes if too long. (unlikely)"
+ ^ '"is a pool variable from the pool ' , (Smalltalk globals keyAtIdentityValue: reply) asString , ', which is used by the following classes ' , classes contents printString , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (' , (Smalltalk globals keyAtIdentityValue: reply) asString , ' bindingOf: #' , symbol , ').'].
+ ^ nil!
Item was added:
+ ----- Method: TextEditor>>explainCtxt: (in category 'explain') -----
+ explainCtxt: symbol
+ "Is symbol a context variable?"
+
+ | reply classes text cls |
+ symbol = #nil ifTrue: [reply := '"is a constant. It is the only instance of class UndefinedObject. nil is the initial value of all variables."'].
+ symbol = #true ifTrue: [reply := '"is a constant. It is the only instance of class True and is the receiver of many control messages."'].
+ symbol = #false ifTrue: [reply := '"is a constant. It is the only instance of class False and is the receiver of many control messages."'].
+ symbol = #thisContext ifTrue: [reply := '"is a context variable. Its value is always the MethodContext which is executing this method."'].
+ (model respondsTo: #selectedClassOrMetaClass) ifTrue: [
+ cls := model selectedClassOrMetaClass].
+ cls ifNil: [^ reply]. "no class known"
+ symbol = #self ifTrue:
+ [classes := cls withAllSubclasses.
+ classes size > 12
+ ifTrue: [text := cls printString , ' or a subclass']
+ ifFalse:
+ [classes := classes printString.
+ text := 'one of these classes' , (classes copyFrom: 4 to: classes size)].
+ reply := '"is the receiver of this message; an instance of ' , text , '"'].
+ symbol = #super ifTrue: [reply := '"is just like self. Messages to super are looked up in the superclass (' , cls superclass printString , ')"'].
+ ^reply!
Item was added:
+ ----- Method: TextEditor>>explainDelimitor: (in category 'explain') -----
+ explainDelimitor: string
+ "Is string enclosed in delimitors?"
+
+ | str |
+ (string at: 1) isLetter ifTrue: [^nil]. "only special chars"
+ (string first = string last) ifTrue:
+ [^ self explainChar: (String with: string first)]
+ ifFalse:
+ [(string first = $( and: [string last = $)]) ifTrue:
+ [^ self explainChar: (String with: string first)].
+ (string first = $[ and: [string last = $]]) ifTrue:
+ [^ self explainChar: (String with: string first)].
+ (string first = ${ and: [string last = $}]) ifTrue:
+ [^ self explainChar: (String with: string first)].
+ (string first = $< and: [string last = $>]) ifTrue:
+ [^ self explainChar: (String with: string first)].
+ (string first = $# and: [string last = $)]) ifTrue:
+ [^'"An instance of class Array. The Numbers, Characters, Symbols or Arrays between the parenthesis are the elements of the Array."'].
+ string first = $# ifTrue:
+ [^'"An instance of class Symbol."'].
+ (string first = $$ and: [string size = 2]) ifTrue:
+ [^'"An instance of class Character. This one is the character ', (String with: string last), '."'].
+ (string first = $:) ifTrue:
+ [string = ':=' ifTrue:
+ [^'"Colon equals means assignment. The value of the expression after the := is stored into the variable before it."'].
+ str := string allButFirst.
+ (self explainTemp: str) ifNotNil:
+ [^'"An argument to this block will be bound to the temporary variable ', str, '."']]].
+ ^ nil!
Item was added:
+ ----- Method: TextEditor>>explainGlobal: (in category 'explain') -----
+ explainGlobal: symbol
+ "Is symbol a global variable?"
+ | reply classes |
+ reply := Smalltalk at: symbol ifAbsent: [^nil].
+ (reply class == Dictionary or:[reply isKindOf: SharedPool class])
+ ifTrue:
+ [classes := Set new.
+ self systemNavigation allBehaviorsDo: [:each | (each sharedPools anySatisfy: [:pool | pool == reply])
+ ifTrue: [classes add: each]].
+ classes := classes printString.
+ ^'"is a global variable. It is a pool which is used by the following classes ' , (classes allButFirst: 5) , '"'].
+ (reply isKindOf: Behavior)
+ ifTrue: [^'"is a global variable. ' , symbol , ' is a class in category ', reply category,
+ '."', '\' withCRs, 'Browser newOnClass: ' , symbol , '.'].
+ symbol == #Smalltalk ifTrue: [^'"is a global. Smalltalk is the only instance of SystemDictionary and holds all global variables."'].
+ ^'"is a global variable. ' , symbol , ' is ' , reply printString , '"'!
Item was added:
+ ----- Method: TextEditor>>explainInst: (in category 'explain') -----
+ explainInst: string
+ "Is string an instance variable of this class?"
+ | classes cls |
+
+ (model respondsTo: #selectedClassOrMetaClass) ifTrue: [
+ cls := model selectedClassOrMetaClass].
+ cls ifNil: [^ nil]. "no class known"
+ classes := (Array with: cls)
+ , cls allSuperclasses.
+ classes := classes detect: [:each | each instVarNames anySatisfy: [:name | name = string]] ifNone: [^nil].
+ classes := classes printString.
+ ^ '"is an instance variable of the receiver; defined in class ' , classes ,
+ '"\' withCRs , classes , ' systemNavigation browseAllAccessesTo: ''' , string , ''' from: ', classes, '.'!
Item was added:
+ ----- Method: TextEditor>>explainMySel: (in category 'explain') -----
+ explainMySel: symbol
+ "Is symbol the selector of this method? Is it sent by this method? If
+ not, then expalin will call (explainPartSel:) to see if it is a fragment of a
+ selector sent here. If not, explain will call (explainAnySel:) to catch any
+ selector. "
+
+ | lits classes msg |
+ (model respondsTo: #selectedMessageName) ifFalse: [^ nil].
+ (msg := model selectedMessageName) ifNil: [^nil]. "not in a message"
+ classes := self systemNavigation allClassesImplementing: symbol.
+ classes size > 12
+ ifTrue: [classes := 'many classes']
+ ifFalse: [classes := 'these classes ' , classes printString].
+ msg = symbol
+ ifTrue: [^ '"' , symbol , ' is the selector of this very method!! It is defined in ',
+ classes , '. To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']
+ ifFalse:
+ [lits := (model selectedClassOrMetaClass compiledMethodAt:
+ msg) messages.
+ (lits anySatisfy: [:each | each == symbol])
+ ifFalse: [^nil].
+ ^ '"' , symbol , ' is a message selector which is defined in ', classes , '. To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].!
Item was added:
+ ----- Method: TextEditor>>explainNumber: (in category 'explain') -----
+ explainNumber: string
+ "Is string a Number?"
+
+ | strm c |
+ (c := string at: 1) isDigit ifFalse: [(c = $- and: [string size > 1 and: [(string at: 2) isDigit]])
+ ifFalse: [^nil]].
+ strm := ReadStream on: string.
+ c := Number readFrom: strm.
+ strm atEnd ifFalse: [^nil].
+ c printString = string
+ ifTrue: [^'"' , string , ' is a ' , c class name , '"']
+ ifFalse: [^'"' , string , ' (= ' , c printString , ') is a ' , c class name , '"']!
Item was added:
+ ----- Method: TextEditor>>explainPartSel: (in category 'explain') -----
+ explainPartSel: string
+ "Is this a fragment of a multiple-argument selector sent in this method?"
+ | lits whole reply classes s msg |
+
+ (model respondsTo: #selectedMessageName) ifFalse: [^ nil].
+ (msg := model selectedMessageName) ifNil: [^ nil]. "not in a message"
+ string last == $: ifFalse: [^ nil].
+ "Name of this method"
+ lits := Array with: msg.
+ (whole := lits detect: [:each | each keywords anySatisfy: [:frag | frag = string] ]
+ ifNone: []) ~~ nil
+ ifTrue: [reply := ', which is the selector of this very method!!'.
+ s := '. To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']
+ ifFalse:
+ ["Selectors called from this method"
+ lits := (model selectedClassOrMetaClass compiledMethodAt:
+ msg) messages.
+ (whole := lits detect: [:each | (each keywords detect: [:frag | frag = string]
+ ifNone: []) ~~ nil]
+ ifNone: []) ~~ nil
+ ifFalse: [string = 'primitive:'
+ ifTrue: [^self explainChar: '<']
+ ifFalse: [^nil]].
+ reply := '.'.
+ s := '. To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].
+ classes := self systemNavigation allClassesImplementing: whole.
+ classes size > 12
+ ifTrue: [classes := 'many classes']
+ ifFalse: [classes := 'these classes ' , classes printString].
+ ^ '"' , string , ' is one part of the message selector ' , whole, reply , ' It is defined in ' , classes , s!
Item was added:
+ ----- Method: TextEditor>>explainScan: (in category 'explain') -----
+ explainScan: string
+ "Remove beginning and trailing space, tab, cr.
+ 1/15/96 sw: copied intact from BrowserCodeController"
+
+ | c beg end |
+ beg := 1.
+ end := string size.
+
+ [beg = end ifTrue: [^string copyFrom: 1 to: 1].
+ "if all blank, tell about the first"
+ c := string at: beg.
+ c = Character space or: [c = Character tab or: [c = Character cr]]]
+ whileTrue: [beg := beg + 1].
+
+ [c := string at: end.
+ c = Character space or: [c = Character tab or: [c = Character cr]]]
+ whileTrue: [end := end - 1].
+ ^string copyFrom: beg to: end "Return purely visible characters"!
Item was added:
+ ----- Method: TextEditor>>explainTemp: (in category 'explain') -----
+ explainTemp: string
+ "Is string the name of a temporary variable (method or block argument or temporary)?"
+
+ | selectedClass methodNode tempNode |
+ (model respondsTo: #selectedMessageName) ifFalse: [^ nil].
+ model selectedMessageName ifNil: [^nil]. "not in a method"
+ selectedClass := model selectedClassOrMetaClass.
+ methodNode := selectedClass newParser parse: model selectedMessage class: selectedClass.
+ tempNode := methodNode encoder tempNodes detect: [:n| n name = string] ifNone: [^nil].
+ ^(tempNode isArg
+ ifTrue: ['"is an argument to this ']
+ ifFalse: ['"is a temporary variable in this ']),
+ (tempNode isDeclaredAtMethodLevel
+ ifTrue: ['method"']
+ ifFalse: ['block"'])!
Item was added:
+ ----- Method: TextEditor>>exploreIt (in category 'do-its') -----
+ exploreIt
+ self evaluateSelectionAndDo: [:result | result explore]!
Item was added:
+ ----- Method: TextEditor>>exploreIt: (in category 'editing keys') -----
+ exploreIt: aKeyboardEvent
+ "Explore the selection -- invoked via cmd-shift-I. If there is no current selection, use the current line."
+
+ self exploreIt.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>fileItIn (in category 'menu messages') -----
+ fileItIn
+ "Make a Stream on the text selection and fileIn it.
+ 1/24/96 sw: moved here from FileController; this function can be useful from any text window that shows stuff in chunk format"
+
+ self selectionAsStream fileIn
+ !
Item was added:
+ ----- Method: TextEditor>>fileItIn: (in category 'editing keys') -----
+ fileItIn: aKeyboardEvent
+ "File in the selection; invoked via a keyboard shortcut, -- for now, cmd-shift-G."
+
+ self fileItIn.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>find (in category 'menu messages') -----
+ find
+ "Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw"
+
+ | reply |
+ reply := UIManager default request: 'Find what? ' initialAnswer: ''.
+ reply size = 0 ifTrue: [
+ ^ self].
+ self setSearch: reply.
+ ChangeText := FindText. "Implies no replacement to againOnce: method"
+ self againOrSame: true.
+
+ morph installEditorToReplace: self!
Item was added:
+ ----- Method: TextEditor>>find: (in category 'typing/selecting keys') -----
+ find: aKeyboardEvent
+ "Prompt the user for what to find, then find it, searching from the current selection onward. 1/24/96 sw"
+
+ self insertAndCloseTypeIn.
+ self find.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>findAgain (in category 'menu messages') -----
+ findAgain
+ "Find the text-to-find again. 1/24/96 sw"
+
+ self againOrSame: true!
Item was added:
+ ----- Method: TextEditor>>findAgain: (in category 'typing/selecting keys') -----
+ findAgain: aKeyboardEvent
+ "Find the desired text again. 1/24/96 sw"
+
+ self insertAndCloseTypeIn.
+ self againOrSame: true many: aKeyboardEvent shiftPressed.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>flash (in category 'displaying') -----
+ flash
+ ^ morph flash!
Item was added:
+ ----- Method: TextEditor>>forwardDelete: (in category 'typing/selecting keys') -----
+ forwardDelete: aKeyboardEvent
+ "Delete forward over the next character.
+ Make Undo work on the whole type-in, not just the one char.
+ wod 11/3/1998: If there was a selection use #zapSelectionWith: rather than #backspace: which was 'one off' in deleting the selection. Handling of things like undo or typeIn area were not fully considered."
+ | startIndex usel upara uinterval ind stopIndex |
+ startIndex := self markIndex.
+ startIndex > self text size ifTrue: [
+ ^ false].
+ self hasSelection ifTrue: [
+ "there was a selection"
+ self zapSelectionWith: self nullText.
+ ^ false].
+ "Null selection - do the delete forward"
+ beginTypeInIndex ifNil: [ "no previous typing. openTypeIn"
+ self openTypeIn. UndoSelection := self nullText].
+ uinterval := UndoInterval copy.
+ upara := UndoParagraph copy.
+ stopIndex := startIndex.
+ (aKeyboardEvent keyValue = 127 and: [ aKeyboardEvent shiftPressed ])
+ ifTrue: [stopIndex := (self nextWord: stopIndex) - 1].
+ self selectFrom: startIndex to: stopIndex.
+ self replaceSelectionWith: self nullText.
+ self selectFrom: startIndex to: startIndex-1.
+ UndoParagraph := upara. UndoInterval := uinterval.
+ UndoMessage selector == #noUndoer ifTrue: [
+ (UndoSelection isText) ifTrue: [
+ usel := UndoSelection.
+ ind := startIndex. "UndoInterval startIndex"
+ usel replaceFrom: usel size + 1 to: usel size with:
+ (UndoParagraph text copyFrom: ind to: ind).
+ UndoParagraph text replaceFrom: ind to: ind with: self nullText]].
+ ^false!
Item was added:
+ ----- Method: TextEditor>>handleEmphasisExtra:with: (in category 'editing keys') -----
+ handleEmphasisExtra: index with: aKeyboardEvent
+ "Handle an emphasis extra choice"
+ ^true!
Item was added:
+ ----- Method: TextEditor>>hasCaret (in category 'accessing-selection') -----
+ hasCaret
+ ^ markBlock = pointBlock!
Item was added:
+ ----- Method: TextEditor>>hiddenInfo (in category 'editing keys') -----
+ hiddenInfo
+ "In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden info. Return the entire string that was used by Cmd-6 to create this text attribute. Usually enclosed in < >."
+
+ | attrList |
+ attrList := self text attributesAt: (self pointIndex + self markIndex)//2.
+ attrList do: [:attr |
+ (attr isKindOf: TextAction) ifTrue:
+ [^ self selection asString, '<', attr info, '>']].
+ "If none of the above"
+ attrList do: [:attr |
+ attr class == TextColor ifTrue:
+ [^ self selection asString, '<', attr color printString, '>']].
+ ^ self selection asString, '[No hidden info]'!
Item was added:
+ ----- Method: TextEditor>>implementorsOfIt (in category 'menu messages') -----
+ implementorsOfIt
+ "Open an implementors browser on the selected selector"
+ | aSelector |
+ self lineSelectAndEmptyCheck: [^ self].
+ (aSelector := self selectedSelector) == nil ifTrue: [^ morph flash].
+ model browseAllImplementorsOf: aSelector!
Item was added:
+ ----- Method: TextEditor>>implementorsOfIt: (in category 'editing keys') -----
+ implementorsOfIt: aKeyboardEvent
+ "Triggered by Cmd-m; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw"
+
+ self implementorsOfIt.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>inOutdent:delta: (in category 'editing keys') -----
+ inOutdent: aKeyboardEvent delta: delta
+ "Add/remove a tab at the front of every line occupied by the selection. Flushes typeahead. Derived from work by Larry Tesler back in December 1985. Now triggered by Cmd-L and Cmd-R. 2/29/96 sw"
+
+ | realStart realStop lines startLine stopLine start stop adjustStart indentation numLines oldString newString newSize |
+
+ "Operate on entire lines, but remember the real selection for re-highlighting later"
+ realStart := self startIndex.
+ realStop := self stopIndex - 1.
+
+ "Special case a caret on a line of its own, including weird case at end of paragraph"
+ (realStart > realStop and:
+ [realStart < 2 or: [(paragraph string at: realStart - 1) == Character cr or: [(paragraph string at: realStart - 1) == Character lf]]])
+ ifTrue:
+ [delta < 0
+ ifTrue:
+ [morph flash]
+ ifFalse:
+ [self replaceSelectionWith: Character tab asText.
+ self selectAt: realStart + 1].
+ ^true].
+
+ lines := paragraph lines.
+ startLine := paragraph lineIndexOfCharacterIndex: realStart.
+ "start on a real line, not a wrapped line"
+ [startLine = 1 or: [CharacterSet crlf includes: (paragraph string at: (lines at: startLine-1) last)]] whileFalse: [startLine := startLine - 1].
+ stopLine := paragraph lineIndexOfCharacterIndex: (realStart max: realStop).
+ start := (lines at: startLine) first.
+ stop := (lines at: stopLine) last.
+
+ "Pin the start of highlighting unless the selection starts a line"
+ adjustStart := realStart > start.
+
+ "Find the indentation of the least-indented non-blank line; never outdent more"
+ indentation := (startLine to: stopLine) inject: 1000 into:
+ [:m :l |
+ m min: (paragraph indentationOfLineIndex: l ifBlank: [:tabs | 1000])].
+ indentation + delta <= 0 ifTrue: ["^false"].
+
+ numLines := stopLine + 1 - startLine.
+ oldString := paragraph string copyFrom: start to: stop.
+ newString := oldString species new: oldString size + ((numLines * delta) max: 0).
+
+ "Do the actual work"
+ newSize := 0.
+ delta > 0
+ ifTrue: [| tabs |
+ tabs := oldString species new: delta withAll: Character tab.
+ oldString lineIndicesDo: [:startL :endWithoutDelimiters :endL |
+ startL < endWithoutDelimiters ifTrue: [newString replaceFrom: 1 + newSize to: (newSize := newSize + delta) with: tabs startingAt: 1].
+ newString replaceFrom: 1 + newSize to: (newSize := 1 + newSize + endL - startL) with: oldString startingAt: startL]]
+ ifFalse: [| tab |
+ tab := Character tab.
+ oldString lineIndicesDo: [:startL :endWithoutDelimiters :endL |
+ | i |
+ i := 0.
+ [i + delta < 0 and: [ i + startL <= endWithoutDelimiters and: [(oldString at: i + startL) == tab]]] whileTrue: [i := i + 1].
+ newString replaceFrom: 1 + newSize to: (newSize := 1 + newSize + endL - (i + startL)) with: oldString startingAt: i + startL]].
+ newSize < newString size ifTrue: [newString := newString copyFrom: 1 to: newSize].
+
+ "Adjust the range that will be highlighted later"
+ adjustStart ifTrue: [realStart := (realStart + delta) max: start].
+ realStop := realStop + newSize - oldString size.
+
+ "Replace selection"
+ self selectInvisiblyFrom: start to: stop.
+ self replaceSelectionWith: newString asText.
+ self selectFrom: realStart to: realStop. "highlight only the original range"
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>indent: (in category 'editing keys') -----
+ indent: aKeyboardEvent
+ "Add a tab at the front of every line occupied by the selection. Invoked from keyboard via cmd-shift-R. 2/29/96 sw"
+
+ ^ self inOutdent: aKeyboardEvent delta: 1!
Item was added:
+ ----- Method: TextEditor>>indent:fromStream:toStream: (in category 'private') -----
+ indent: delta fromStream: inStream toStream: outStream
+ "Append the contents of inStream to outStream, adding or deleting delta or -delta
+ tabs at the beginning, and after every CR except a final CR. Do not add tabs
+ to totally empty lines, and be sure nothing but tabs are removed from lines."
+
+ | ch skip cr tab prev atEnd |
+ cr := Character cr.
+ tab := Character tab.
+ delta > 0
+ ifTrue: "shift right"
+ [prev := cr.
+ [ch := (atEnd := inStream atEnd) ifTrue: [cr] ifFalse: [inStream next].
+ (prev == cr and: [ch ~~ cr]) ifTrue:
+ [delta timesRepeat: [outStream nextPut: tab]].
+ atEnd]
+ whileFalse:
+ [outStream nextPut: ch.
+ prev := ch]]
+ ifFalse: "shift left"
+ [skip := delta. "a negative number"
+ [inStream atEnd] whileFalse:
+ [((ch := inStream next) == tab and: [skip < 0]) ifFalse:
+ [outStream nextPut: ch].
+ skip := ch == cr ifTrue: [delta] ifFalse: [skip + 1]]]!
Item was added:
+ ----- Method: TextEditor>>insertAndCloseTypeIn (in category 'typing support') -----
+ insertAndCloseTypeIn
+ self
+ insertTypeAhead ;
+ closeTypeIn!
Item was added:
+ ----- Method: TextEditor>>insertAndSelect:at: (in category 'new selection') -----
+ insertAndSelect: aString at: anInteger
+
+ self replace: (anInteger to: anInteger - 1)
+ with: (Text string: (' ' , aString)
+ attributes: emphasisHere)
+ and: [self ]!
Item was added:
+ ----- Method: TextEditor>>insertTypeAhead (in category 'typing support') -----
+ insertTypeAhead
+ self typeAhead position = 0 ifFalse:
+ [self zapSelectionWith: (Text string: self typeAhead contents emphasis: emphasisHere).
+ self typeAhead reset.
+ self unselect]!
Item was added:
+ ----- Method: TextEditor>>inspectIt (in category 'do-its') -----
+ inspectIt
+ self evaluateSelectionAndDo: [:result | result inspect]!
Item was added:
+ ----- Method: TextEditor>>inspectIt: (in category 'editing keys') -----
+ inspectIt: aKeyboardEvent
+ "Inspect the selection -- invoked via cmd-i. If there is no current selection, use the current line. 1/17/96 sw
+ 2/29/96 sw: don't call selectLine; it's done by inspectIt now"
+
+ self inspectIt.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>isDisjointFrom: (in category 'private') -----
+ isDisjointFrom: anInterval
+ "Answer true if anInterval is a caret not touching or within the current
+ interval, or if anInterval is a non-caret that does not overlap the current
+ selection."
+
+ | fudge |
+ fudge := anInterval size = 0 ifTrue: [1] ifFalse: [0].
+ ^(anInterval last + fudge < self startIndex or:
+ [anInterval first - fudge >= self stopIndex])
+ !
Item was added:
+ ----- Method: TextEditor>>isDoing (in category 'undo support') -----
+ isDoing
+ "Call from a doer/undoer/redoer any time to see which it is."
+
+ ^(self isUndoing | self isRedoing) not!
Item was added:
+ ----- Method: TextEditor>>isRedoing (in category 'undo support') -----
+ isRedoing
+ "Call from a doer/undoer/redoer any time to see which it is."
+
+ ^UndoParagraph == #redoing!
Item was added:
+ ----- Method: TextEditor>>isUndoing (in category 'undo support') -----
+ isUndoing
+ "Call from a doer/undoer/redoer any time to see which it is."
+
+ ^UndoParagraph == #undoing!
Item was added:
+ ----- Method: TextEditor>>keyStroke: (in category 'events') -----
+ keyStroke: anEvent
+ self resetTypeAhead; deselect.
+ (self dispatchOnKeyboardEvent: anEvent)
+ ifTrue:
+ [self doneTyping.
+ self storeSelectionInParagraph.
+ ^self].
+ self openTypeIn.
+ self hasSelection ifTrue: [ "save highlighted characters"
+ UndoSelection := self selection].
+ self
+ zapSelectionWith: self typeAhead contents ;
+ resetTypeAhead ;
+ unselect ;
+ storeSelectionInParagraph!
Item was added:
+ ----- Method: TextEditor>>lineSelectAndEmptyCheck: (in category 'new selection') -----
+ lineSelectAndEmptyCheck: returnBlock
+ "If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this."
+
+ self selectLine. "if current selection is an insertion point, then first select the entire line in which occurs before proceeding"
+ self hasSelection ifFalse: [morph flash. ^ returnBlock value]!
Item was added:
+ ----- Method: TextEditor>>makeCapitalized: (in category 'editing keys') -----
+ makeCapitalized: aKeyboardEvent
+ "Force the current selection to uppercase. Triggered by Cmd-X."
+
+ | prev |
+ prev := $-. "not a letter"
+ self replaceSelectionWith:
+ (self selection string collect:
+ [:c | prev := prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]]).
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>makeLowercase: (in category 'editing keys') -----
+ makeLowercase: aKeyboardEvent
+ "Force the current selection to lowercase. Triggered by Cmd-X."
+
+ self replaceSelectionWith: (self selection string asLowercase).
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>makeUppercase: (in category 'editing keys') -----
+ makeUppercase: aKeyboardEvent
+ "Force the current selection to uppercase. Triggered by Cmd-Y."
+
+ self replaceSelectionWith: (self selection string asUppercase).
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>markIndex (in category 'accessing-selection') -----
+ markIndex
+ ^ markBlock stringIndex!
Item was added:
+ ----- Method: TextEditor>>markIndex:pointIndex: (in category 'accessing-selection') -----
+ markIndex: anIndex pointIndex: anotherIndex
+ "Called, for example, when selecting text with shift+arrow keys"
+ markBlock := paragraph characterBlockForIndex: anIndex.
+ pointBlock := paragraph characterBlockForIndex: anotherIndex!
Item was added:
+ ----- Method: TextEditor>>methodNamesContainingIt (in category 'menu messages') -----
+ methodNamesContainingIt
+ "Open a browser on methods names containing the selected string"
+
+ self lineSelectAndEmptyCheck: [^ self].
+ Cursor wait showWhile:
+ [self systemNavigation browseMethodsWhoseNamesContain: self selection string withBlanksTrimmed].
+ Cursor normal show!
Item was added:
+ ----- Method: TextEditor>>methodNamesContainingIt: (in category 'editing keys') -----
+ methodNamesContainingIt: aKeyboardEvent
+ "Browse methods whose selectors containing the selection in their names"
+
+ self methodNamesContainingIt.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>methodSourceContainingIt (in category 'menu messages') -----
+ methodSourceContainingIt
+ "Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source). Slow!!"
+
+ self lineSelectAndEmptyCheck: [^ self].
+ self systemNavigation browseMethodsWithSourceString: self selection string!
Item was added:
+ ----- Method: TextEditor>>methodStringsContainingIt: (in category 'editing keys') -----
+ methodStringsContainingIt: aKeyboardEvent
+ "Invoked from cmd-E -- open a browser on all methods holding string constants containing it. Flushes typeahead. "
+
+ self methodStringsContainingit.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>methodStringsContainingit (in category 'menu messages') -----
+ methodStringsContainingit
+ "Open a browser on methods which contain the current selection as part of a string constant."
+
+ self lineSelectAndEmptyCheck: [^ self].
+ self systemNavigation browseMethodsWithString: self selection string!
Item was added:
+ ----- Method: TextEditor>>model (in category 'accessing') -----
+ model
+
+ ^model!
Item was added:
+ ----- Method: TextEditor>>model: (in category 'model access') -----
+ model: aModel
+ model := aModel!
Item was added:
+ ----- Method: TextEditor>>mouseDown: (in category 'events') -----
+ mouseDown: evt
+ "An attempt to break up the old processRedButton code into threee phases"
+ | clickPoint b |
+
+ oldInterval := self selectionInterval.
+ clickPoint := evt cursorPoint.
+ b := paragraph characterBlockAtPoint: clickPoint.
+
+ (paragraph clickAt: clickPoint for: model controller: self) ifTrue: [
+ markBlock := b.
+ pointBlock := b.
+ evt hand releaseKeyboardFocus: self.
+ ^ self ].
+
+ evt shiftPressed
+ ifFalse: [
+ self closeTypeIn.
+ markBlock := b.
+ pointBlock := b ]
+ ifTrue: [
+ self closeTypeIn.
+ self mouseMove: evt ].
+ self storeSelectionInParagraph!
Item was added:
+ ----- Method: TextEditor>>mouseMove: (in category 'events') -----
+ mouseMove: evt
+ "Change the selection in response to mouse-down drag"
+
+ pointBlock := paragraph characterBlockAtPoint: evt position.
+ self storeSelectionInParagraph!
Item was added:
+ ----- Method: TextEditor>>mouseUp: (in category 'events') -----
+ mouseUp: evt
+ "An attempt to break up the old processRedButton code into threee phases"
+ oldInterval ifNil: [^ self]. "Patched during clickAt: repair"
+ (self hasCaret
+ and: [oldInterval = self selectionInterval])
+ ifTrue: [self selectWord].
+ self setEmphasisHere.
+ (self isDisjointFrom: oldInterval) ifTrue:
+ [otherInterval := oldInterval].
+ self storeSelectionInParagraph!
Item was added:
+ ----- Method: TextEditor>>moveCursor:forward:event:specialBlock: (in category 'private') -----
+ moveCursor: directionBlock forward: forward event: aKeyboardEvent specialBlock: specialBlock
+ super moveCursor: directionBlock forward: forward event: aKeyboardEvent specialBlock: specialBlock.
+ self setEmphasisHere!
Item was added:
+ ----- Method: TextEditor>>nextTokenFrom:direction: (in category 'new selection') -----
+ nextTokenFrom: start direction: dir
+ "simple token-finder for compiler automated corrections"
+ | loc str |
+ loc := start + dir.
+ str := paragraph string.
+ [(loc between: 1 and: str size) and: [(str at: loc) isSeparator]]
+ whileTrue: [loc := loc + dir].
+ ^ loc!
Item was added:
+ ----- Method: TextEditor>>noUndoer (in category 'undo support') -----
+ noUndoer
+ "The Undoer to use when the command can not be undone. Checked for
+ specially by readKeyboard."
+
+ UndoMessage := Message selector: #noUndoer!
Item was added:
+ ----- Method: TextEditor>>notify:at:in: (in category 'new selection') -----
+ notify: aString at: anInteger in: aStream
+ "The compilation of text failed. The syntax error is noted as the argument,
+ aString. Insert it in the text at starting character position anInteger."
+
+ self insertAndSelect: aString at: (anInteger max: 1)!
Item was added:
+ ----- Method: TextEditor>>nullText (in category 'private') -----
+ nullText
+
+ ^Text string: '' attributes: emphasisHere!
Item was added:
+ ----- Method: TextEditor>>offerFontMenu (in category 'attributes') -----
+ offerFontMenu
+ "Present a menu of available fonts, and if one is chosen, apply it to the current selection.
+ Use only names of Fonts of this paragraph "
+
+ ^self changeTextFont!
Item was added:
+ ----- Method: TextEditor>>offerFontMenu: (in category 'editing keys') -----
+ offerFontMenu: aKeyboardEvent
+ "The user typed the command key that requests a font change; Offer the font menu. 5/27/96 sw"
+
+ self insertAndCloseTypeIn.
+ self offerFontMenu.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>offerMenuFromEsc: (in category 'menu commands') -----
+ offerMenuFromEsc: aKeyboardEvent
+ "The escape key was hit while the receiver has the keyboard focus; take action"
+
+ ActiveEvent shiftPressed ifFalse: [
+ self raiseContextMenu: aKeyboardEvent ].
+ ^true!
Item was added:
+ ----- Method: TextEditor>>openTypeIn (in category 'typing support') -----
+ openTypeIn
+ "Set up UndoSelection to null text (to be added to by readKeyboard and backTo:),
+ beginTypeInBlock to keep track of the leftmost backspace, and UndoParameter to tally
+ how many deleted characters were backspaced over rather than 'cut'.
+ You can't undo typing until after closeTypeIn."
+
+ beginTypeInIndex ifNil: [
+ UndoSelection := self nullText.
+ self undoer: #noUndoer with: 0.
+ beginTypeInIndex := self startIndex]!
Item was added:
+ ----- Method: TextEditor>>outdent: (in category 'editing keys') -----
+ outdent: aKeyboardEvent
+ "Remove a tab from the front of every line occupied by the selection.
+ Invoked from keyboard via cmd-shift-L. 2/29/96 sw"
+
+ ^ self inOutdent: aKeyboardEvent delta: -1!
Item was added:
+ ----- Method: TextEditor>>pageHeight (in category 'private') -----
+ pageHeight
+ | howManyLines visibleHeight totalHeight ratio |
+ howManyLines := paragraph numberOfLines.
+ visibleHeight := self visibleHeight.
+ totalHeight := self totalTextHeight.
+ ratio := visibleHeight / totalHeight.
+ ^(ratio * howManyLines) rounded - 2!
Item was added:
+ ----- Method: TextEditor>>paragraph (in category 'accessing') -----
+ paragraph
+
+ ^paragraph!
Item was added:
+ ----- Method: TextEditor>>pasteInitials: (in category 'editing keys') -----
+ pasteInitials: aKeyboardEvent
+ "Replace the current text selection by an authorship name/date stamp; invoked by cmd-shift-v, easy way to put an authorship stamp in the comments of an editor."
+
+ self insertAndCloseTypeIn.
+ self replace: self selectionInterval with: (Text fromString: Utilities changeStamp) and: [self selectAt: self stopIndex].
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>pasteRecent (in category 'menu messages') -----
+ pasteRecent
+ "Paste an item chose from RecentClippings."
+
+ | clipping |
+ (clipping := Clipboard chooseRecentClipping) ifNil: [^ self].
+ Clipboard clipboardText: clipping.
+ ^ self paste!
Item was added:
+ ----- Method: TextEditor>>pointBlock (in category 'accessing-selection') -----
+ pointBlock
+ ^ pointBlock!
Item was added:
+ ----- Method: TextEditor>>pointIndex (in category 'accessing-selection') -----
+ pointIndex
+ ^ pointBlock stringIndex!
Item was added:
+ ----- Method: TextEditor>>prettyPrint (in category 'menu messages') -----
+ prettyPrint
+ self prettyPrint: false!
Item was added:
+ ----- Method: TextEditor>>prettyPrint: (in category 'menu messages') -----
+ prettyPrint: decorated
+ "Reformat the contents of the receiver's view (a Browser)."
+ | selectedClass newText |
+ selectedClass := model selectedClassOrMetaClass.
+ selectedClass ifNil: [ ^ morph flash ].
+ newText := selectedClass newCompiler
+ format: self text
+ in: selectedClass
+ notifying: self
+ decorated: decorated.
+ newText ifNotNil:
+ [ self
+ deselect ;
+ selectInvisiblyFrom: 1
+ to: paragraph text size.
+ self replaceSelectionWith: (newText asText makeSelectorBoldIn: selectedClass).
+ self selectAt: self text size + 1 ]!
Item was added:
+ ----- Method: TextEditor>>prettyPrintWithColor (in category 'menu messages') -----
+ prettyPrintWithColor
+ self prettyPrint: true!
Item was added:
+ ----- Method: TextEditor>>printIt (in category 'do-its') -----
+ printIt
+
+ self evaluateSelectionAndDo: [:result |
+ (model respondsTo: #printIt:result:)
+ ifTrue: [model
+ perform: #printIt:result:
+ with: self selection
+ with: result]
+ ifFalse: [self afterSelectionInsertAndSelect: result printString]]!
Item was added:
+ ----- Method: TextEditor>>printIt: (in category 'editing keys') -----
+ printIt: aKeyboardEvent
+ "Print the results of evaluting the selection -- invoked via cmd-p. If there is no current selection, use the current line. 1/17/96 sw
+ 2/29/96 sw: don't call selectLine now, since it's called by doIt"
+
+ self printIt.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>querySymbol: (in category 'typing/selecting keys') -----
+ querySymbol: aKeyboardEvent
+ "Invoked by Ctrl-q to query the Symbol table and display alternate symbols.
+ See comment in completeSymbol:lastOffering: for details."
+
+ self insertAndCloseTypeIn.
+ self hasCaret
+ ifTrue: "Ctrl-q typed when a caret"
+ [self perform: #completeSymbol:lastOffering: withArguments:
+ ((UndoParagraph == paragraph and: [UndoMessage sends: #undoQuery:lastOffering:])
+ ifTrue: [UndoMessage arguments] "repeated Ctrl-q"
+ ifFalse: [Array with: nil with: nil])] "initial Ctrl-q"
+ ifFalse: "Ctrl-q typed when statements were highlighted"
+ [morph flash].
+ ^true!
Item was added:
+ ----- Method: TextEditor>>raiseContextMenu: (in category 'nonediting/nontyping keys') -----
+ raiseContextMenu: aKeyboardEvent
+ (morph respondsTo: #editView)
+ ifTrue: [morph editView yellowButtonActivity: false].
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>recomputeSelection (in category 'current selection') -----
+ recomputeSelection
+ "The same characters are selected but their coordinates may have changed."
+
+ self markIndex: self markIndex pointIndex: self pointIndex!
Item was added:
+ ----- Method: TextEditor>>referencesToIt (in category 'menu messages') -----
+ referencesToIt
+ "Open a MessageSet with the references to the selected global or variable name."
+ | selection environment binding |
+ self selection isEmpty ifTrue: [ self selectWord ].
+ environment := (model respondsTo: #selectedClassOrMetaClass)
+ ifTrue: [ model selectedClassOrMetaClass ifNil: [ Smalltalk globals ] ]
+ ifFalse: [ Smalltalk globals ].
+ selection := self selectedSymbol ifNil: [ self selection asString ].
+ (environment isBehavior and:
+ [ (environment
+ instVarIndexFor: selection
+ ifAbsent: [ 0 ]) ~= 0 ]) ifTrue: [ ^ self systemNavigation
+ browseAllAccessesTo: selection
+ from: environment ].
+ selection isSymbol ifFalse: [ ^ morph flash ].
+ binding := (environment bindingOf: selection) ifNil: [ ^ morph flash ].
+ self systemNavigation browseAllCallsOn: binding!
Item was added:
+ ----- Method: TextEditor>>referencesToIt: (in category 'editing keys') -----
+ referencesToIt: aKeyboardEvent
+ "Triggered by Cmd-N; browse references to the current selection"
+
+ self referencesToIt.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>replace:with:and: (in category 'accessing') -----
+ replace: xoldInterval with: newText and: selectingBlock
+ "Replace the text in oldInterval with newText and execute selectingBlock to establish the new selection. Create an undoAndReselect:redoAndReselect: undoer to allow perfect undoing."
+
+ | undoInterval |
+ undoInterval := self selectionInterval.
+ undoInterval = xoldInterval ifFalse: [self selectInterval: xoldInterval].
+ UndoSelection := self selection.
+ self zapSelectionWith: newText.
+ selectingBlock value.
+ otherInterval := self selectionInterval.
+ self undoer: #undoAndReselect:redoAndReselect: with: undoInterval with: otherInterval!
Item was added:
+ ----- Method: TextEditor>>replaceSelectionWith: (in category 'accessing') -----
+ replaceSelectionWith: aText
+ "Remember the selection text in UndoSelection.
+ Deselect, and replace the selection text by aText.
+ Remember the resulting selectionInterval in UndoInterval and PriorInterval.
+ Set up undo to use UndoReplace."
+
+ beginTypeInIndex ifNotNil: [^self zapSelectionWith: aText]. "called from old code"
+ UndoSelection := self selection.
+ self zapSelectionWith: aText.
+ self undoer: #undoReplace!
Item was added:
+ ----- Method: TextEditor>>resetState (in category 'initialize-release') -----
+ resetState
+ "Establish the initial conditions for editing the paragraph: place caret
+ before first character, set the emphasis to that of the first character,
+ and save the paragraph for purposes of canceling."
+
+ pointBlock := markBlock := paragraph defaultCharacterBlock.
+ beginTypeInIndex := nil.
+ UndoInterval := otherInterval := 1 to: 0.
+ self setEmphasisHere.
+ selectionShowing := false!
Item was added:
+ ----- Method: TextEditor>>resetTypeAhead (in category 'private') -----
+ resetTypeAhead
+ typeAhead := WriteStream on: (String new: 1)!
Item was added:
+ ----- Method: TextEditor>>reverseSelection (in category 'current selection') -----
+ reverseSelection
+ "Reverse the valence of the current selection highlighting."
+ selectionShowing := selectionShowing not.
+ paragraph reverseFrom: pointBlock to: markBlock!
Item was added:
+ ----- Method: TextEditor>>sameColumn:newLine:forward: (in category 'private') -----
+ sameColumn: start newLine: lineBlock forward: isForward
+ "Private - Compute the index in my text
+ with the line number derived from lineBlock,"
+ " a one argument block accepting the old line number.
+ The position inside the line will be preserved as good as possible"
+ "The boolean isForward is used in the border case to determine if
+ we should move to the beginning or the end of the line."
+ | wordStyle column currentLine offsetAtTargetLine targetEOL lines numberOfLines currentLineNumber targetLineNumber |
+ wordStyle := Preferences wordStyleCursorMovement.
+ wordStyle
+ ifTrue: [
+ lines := paragraph lines.
+ numberOfLines := paragraph numberOfLines.
+ currentLineNumber := paragraph lineIndexOfCharacterIndex: start.
+ currentLine := lines at: currentLineNumber]
+ ifFalse: [
+ lines := self lines.
+ numberOfLines := lines size.
+ currentLine := lines
+ detect:[:lineInterval | lineInterval last >= start]
+ ifNone:[lines last].
+ currentLineNumber := currentLine second].
+ column := start - currentLine first.
+ targetLineNumber := ((lineBlock value: currentLineNumber) max: 1) min: numberOfLines.
+ offsetAtTargetLine := (lines at: targetLineNumber) first.
+ targetEOL := (lines at: targetLineNumber) last + (targetLineNumber = numberOfLines ifTrue:[1]ifFalse:[0]).
+ targetLineNumber = currentLineNumber
+ "No movement or movement failed. Move to beginning or end of line."
+ ifTrue:[^isForward
+ ifTrue:[targetEOL]
+ ifFalse:[offsetAtTargetLine]].
+ ^offsetAtTargetLine + column min: targetEOL.!
Item was added:
+ ----- Method: TextEditor>>save: (in category 'editing keys') -----
+ save: aKeyboardEvent
+ "Submit the current text. Equivalent to 'accept' 1/18/96 sw"
+
+ self insertAndCloseTypeIn.
+ self accept.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>saveContentsInFile (in category 'menu messages') -----
+ saveContentsInFile
+ "Save the receiver's contents string to a file, prompting the user for a file-name. Suggest a reasonable file-name."
+
+ | fileName stringToSave parentWindow labelToUse suggestedName |
+ stringToSave := paragraph text string.
+ stringToSave size = 0 ifTrue: [^self inform: 'nothing to save.'].
+ parentWindow := model dependents
+ detect: [:dep | dep isKindOf: SystemWindow]
+ ifNone: [nil].
+ labelToUse := parentWindow ifNil: ['Untitled']
+ ifNotNil: [parentWindow label].
+ suggestedName := nil.
+ #(#('Decompressed contents of: ' '.gz')) do:
+ [:leaderTrailer | | lastIndex |
+ "can add more here..."
+
+ (labelToUse beginsWith: leaderTrailer first)
+ ifTrue:
+ [suggestedName := labelToUse copyFrom: leaderTrailer first size + 1
+ to: labelToUse size.
+ (labelToUse endsWith: leaderTrailer last)
+ ifTrue:
+ [suggestedName := suggestedName copyFrom: 1
+ to: suggestedName size - leaderTrailer last size]
+ ifFalse:
+ [lastIndex := suggestedName lastIndexOf: $. ifAbsent: [0].
+ (lastIndex = 0 or: [lastIndex = 1])
+ ifFalse: [suggestedName := suggestedName copyFrom: 1 to: lastIndex - 1]]]].
+ suggestedName ifNil: [suggestedName := labelToUse , '.text'].
+ fileName := UIManager default request: 'File name?'
+ initialAnswer: suggestedName.
+ fileName isEmptyOrNil
+ ifFalse:
+ [(FileStream newFileNamed: fileName)
+ nextPutAll: stringToSave;
+ close]!
Item was added:
+ ----- Method: TextEditor>>scrollBy: (in category 'scrolling') -----
+ scrollBy: ignore
+ "Ignore scroll requests."!
Item was added:
+ ----- Method: TextEditor>>search: (in category 'typing/selecting keys') -----
+ search: aKeyboardEvent
+ "Invoked by Ctrl-S. Same as 'again', but always uses the existing FindText
+ and ChangeText regardless of the last edit."
+
+ self insertAndCloseTypeIn.
+ self
+ againOrSame: true "true means use same keys"
+ many: aKeyboardEvent shiftPressed.
+ ^true!
Item was added:
+ ----- Method: TextEditor>>selectAndScroll (in category 'current selection') -----
+ selectAndScroll
+ "Ignore scroll requests."!
Item was added:
+ ----- Method: TextEditor>>selectCurrentTypeIn: (in category 'nonediting/nontyping keys') -----
+ selectCurrentTypeIn: aKeyboardEvent
+ "Select what would be replaced by an undo (e.g., the last typeIn)."
+
+ | prior |
+
+ self insertAndCloseTypeIn.
+ prior := otherInterval.
+ self insertAndCloseTypeIn.
+ self selectInterval: UndoInterval.
+ otherInterval := prior.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>selectFrom:to: (in category 'new selection') -----
+ selectFrom: start to: stop
+ "Select the specified characters inclusive."
+ self selectInvisiblyFrom: start to: stop.
+ self closeTypeIn.
+ self storeSelectionInParagraph.
+ "Preserve current emphasis if selection is empty"
+ stop > start ifTrue: [
+ self setEmphasisHere ]!
Item was added:
+ ----- Method: TextEditor>>selectLine (in category 'new selection') -----
+ selectLine
+ "Make the receiver's selection, if it currently consists of an insertion point only, encompass the current line."
+ self hasSelection ifTrue:[^self].
+ self selectInterval: (self encompassLine: self selectionInterval)!
Item was added:
+ ----- Method: TextEditor>>selectPrecedingIdentifier (in category 'new selection') -----
+ selectPrecedingIdentifier
+ "Invisibly select the identifier that ends at the end of the selection, if any."
+
+ | string sep stop tok |
+ tok := false.
+ string := paragraph string.
+ stop := self stopIndex - 1.
+ [stop > 0 and: [(string at: stop) isSeparator]] whileTrue: [stop := stop - 1].
+ sep := stop.
+ [sep > 0 and: [(string at: sep) tokenish]] whileTrue: [tok := true. sep := sep - 1].
+ tok ifTrue: [self selectInvisiblyFrom: sep + 1 to: stop]!
Item was added:
+ ----- Method: TextEditor>>selectedSelector (in category 'menu messages') -----
+ selectedSelector
+ "Try to make a selector out of the current text selection"
+ ^self selection string findSelector!
Item was added:
+ ----- Method: TextEditor>>selectedSymbol (in category 'menu messages') -----
+ selectedSymbol
+ "Return the currently selected symbol, or nil if none. Spaces, tabs and returns are ignored"
+
+ | aString |
+ self hasCaret ifTrue: [^ nil].
+ aString := self selection string copyWithoutAll: CharacterSet separators.
+ aString size = 0 ifTrue: [^ nil].
+ Symbol hasInterned: aString ifTrue: [:sym | ^ sym].
+
+ ^ nil!
Item was added:
+ ----- Method: TextEditor>>selection (in category 'accessing-selection') -----
+ selection
+ "Answer the text in the paragraph that is currently selected."
+
+ ^paragraph text copyFrom: self startIndex to: self stopIndex - 1 !
Item was added:
+ ----- Method: TextEditor>>selectionAsStream (in category 'accessing-selection') -----
+ selectionAsStream
+ "Answer a ReadStream on the text in the paragraph that is currently selected."
+
+ ^ReadStream
+ on: paragraph string
+ from: self startIndex
+ to: self stopIndex - 1!
Item was added:
+ ----- Method: TextEditor>>sendersOfIt (in category 'menu messages') -----
+ sendersOfIt
+ "Open a senders browser on the selected selector"
+
+ | aSelector |
+ self lineSelectAndEmptyCheck: [^ self].
+ (aSelector := self selectedSelector) == nil ifTrue: [^ morph flash].
+ self systemNavigation browseAllCallsOn: aSelector!
Item was added:
+ ----- Method: TextEditor>>sendersOfIt: (in category 'editing keys') -----
+ sendersOfIt: aKeyboardEvent
+ "Triggered by Cmd-n; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw"
+
+ self sendersOfIt.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>setAlignment: (in category 'menu messages') -----
+ setAlignment: aSymbol
+ | attr interval |
+ attr := TextAlignment perform: aSymbol.
+ interval := self encompassLine: self selectionInterval.
+ paragraph
+ replaceFrom: interval first
+ to: interval last
+ with: ((paragraph text copyFrom: interval first to: interval last) addAttribute: attr)!
Item was added:
+ ----- Method: TextEditor>>setEmphasis: (in category 'editing keys') -----
+ setEmphasis: emphasisSymbol
+ "Change the emphasis of the current selection."
+
+ | oldAttributes attribute |
+ oldAttributes := paragraph text attributesAt: self selectionInterval first.
+
+ attribute := TextEmphasis perform: emphasisSymbol.
+ (emphasisSymbol == #normal)
+ ifFalse: [oldAttributes do:
+ [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]].
+ self replaceSelectionWith: (self selection addAttribute: attribute)!
Item was added:
+ ----- Method: TextEditor>>setEmphasisHere (in category 'typing support') -----
+ setEmphasisHere
+
+ emphasisHere := (paragraph text attributesAt: (self pointIndex - 1 max: 1) forStyle: paragraph textStyle)
+ select: [:att | att mayBeExtended]!
Item was added:
+ ----- Method: TextEditor>>setEmphasisHereFromText (in category 'typing support') -----
+ setEmphasisHereFromText
+
+ self setEmphasisHereFromTextForward: true!
Item was added:
+ ----- Method: TextEditor>>setEmphasisHereFromTextForward: (in category 'typing support') -----
+ setEmphasisHereFromTextForward: f
+
+ | i t forward delta prevIsSeparator nextIsSeparator |
+ i := self pointIndex.
+ t := self text.
+ "Try to set emphasisHere correctly after whitespace.
+ Most important after a cr, i.e. at the start of a new line"
+ prevIsSeparator := i > 1 and: [ (t at: i-1) isSeparator ].
+ nextIsSeparator := i <= t size and: [ (t at: i) isSeparator ].
+ forward := prevIsSeparator = nextIsSeparator
+ ifTrue: [ f ]
+ ifFalse: [ nextIsSeparator ].
+ delta := forward ifTrue: [ 1 ] ifFalse: [ 0 ].
+ emphasisHere := (t attributesAt: (i - delta max: 1))
+ select: [:att | att mayBeExtended].!
Item was added:
+ ----- Method: TextEditor>>setSearch: (in category 'accessing') -----
+ setSearch: aStringOrText
+ "Set the FindText and ChangeText to seek aString; except if already seeking aString, leave ChangeText alone so again will repeat last replacement."
+
+ FindText = aStringOrText
+ ifFalse: [FindText := ChangeText := aStringOrText]!
Item was added:
+ ----- Method: TextEditor>>setSearchString (in category 'menu messages') -----
+ setSearchString
+ "Make the current selection, if any, be the current search string."
+ self hasCaret ifTrue: [morph flash. ^ self].
+ self setSearch: self selection string!
Item was added:
+ ----- Method: TextEditor>>setSearchString: (in category 'nonediting/nontyping keys') -----
+ setSearchString: aKeyboardEvent
+ "Establish the current selection as the current search string."
+
+ | aString |
+ self insertAndCloseTypeIn.
+ self lineSelectAndEmptyCheck: [^ true].
+ aString := self selection string.
+ aString size = 0
+ ifTrue:
+ [self flash]
+ ifFalse:
+ [self setSearch: aString].
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>spawn (in category 'menu messages') -----
+ spawn
+ "Create and schedule a message browser for the code of the model's
+ selected message. Retain any edits that have not yet been accepted."
+ | code |
+ code := paragraph text string.
+ self cancel.
+ model spawn: code.!
Item was added:
+ ----- Method: TextEditor>>spawnIt: (in category 'editing keys') -----
+ spawnIt: aKeyboardEvent
+ "Triggered by Cmd-o; spawn a new code window, if it makes sense."
+
+ self spawn.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>startBlock (in category 'accessing-selection') -----
+ startBlock
+ ^ pointBlock min: markBlock!
Item was added:
+ ----- Method: TextEditor>>startIndex (in category 'accessing-selection') -----
+ startIndex
+ ^ self startBlock stringIndex!
Item was added:
+ ----- Method: TextEditor>>startOfTyping (in category 'typing support') -----
+ startOfTyping
+ "Compatibility during change from characterBlock to integer"
+ beginTypeInIndex == nil ifTrue: [^ nil].
+ beginTypeInIndex isNumber ifTrue: [^ beginTypeInIndex].
+ "Last line for compatibility during change from CharacterBlock to Integer."
+ ^ beginTypeInIndex stringIndex!
Item was added:
+ ----- Method: TextEditor>>stateArray (in category 'initialize-release') -----
+ stateArray
+ ^ {ChangeText.
+ FindText.
+ UndoInterval.
+ UndoMessage.
+ UndoParagraph.
+ UndoSelection.
+ Undone.
+ self selectionInterval.
+ self startOfTyping.
+ emphasisHere}!
Item was added:
+ ----- Method: TextEditor>>stateArrayPut: (in category 'initialize-release') -----
+ stateArrayPut: stateArray
+ | sel |
+ ChangeText := stateArray at: 1.
+ FindText := stateArray at: 2.
+ UndoInterval := stateArray at: 3.
+ UndoMessage := stateArray at: 4.
+ UndoParagraph := stateArray at: 5.
+ UndoSelection := stateArray at: 6.
+ Undone := stateArray at: 7.
+ sel := stateArray at: 8.
+ self selectFrom: sel first to: sel last.
+ beginTypeInIndex := stateArray at: 9.
+ emphasisHere := stateArray at: 10!
Item was added:
+ ----- Method: TextEditor>>stopBlock (in category 'accessing-selection') -----
+ stopBlock
+ ^ pointBlock max: markBlock!
Item was added:
+ ----- Method: TextEditor>>stopIndex (in category 'accessing-selection') -----
+ stopIndex
+ ^ self stopBlock stringIndex!
Item was added:
+ ----- Method: TextEditor>>storeSelectionInParagraph (in category 'mvc compatibility') -----
+ storeSelectionInParagraph
+ paragraph selectionStart: self startBlock selectionStop: self stopBlock!
Item was added:
+ ----- Method: TextEditor>>string (in category 'accessing') -----
+ string
+
+ ^self text string!
Item was added:
+ ----- Method: TextEditor>>styler (in category 'accessing') -----
+ styler
+ "Answers the styler for this editor. Only code editors support syntax highlighting"
+ ^nil!
Item was added:
+ ----- Method: TextEditor>>styler: (in category 'accessing') -----
+ styler: aStyler
+ "Sets the styler for this editor. Only code editors support syntax highlighting"
+ ^nil!
Item was added:
+ ----- Method: TextEditor>>swapChars: (in category 'editing keys') -----
+ swapChars: aKeyboardEvent
+ "Triggered byCmd-Y;. Swap two characters, either those straddling the insertion point, or the two that comprise the selection. Suggested by Ted Kaehler. "
+
+ | currentSelection aString chars |
+ (chars := self selection) size = 0
+ ifTrue:
+ [currentSelection := self pointIndex.
+ self selectMark: currentSelection - 1 point: currentSelection]
+ ifFalse:
+ [chars size = 2
+ ifFalse:
+ [morph flash. ^ true]
+ ifTrue:
+ [currentSelection := self pointIndex - 1]].
+ aString := self selection string.
+ self replaceSelectionWith: (Text string: aString reversed attributes: emphasisHere).
+ self selectAt: currentSelection + 1.
+ ^ true!
Item was added:
+ ----- Method: TextEditor>>tabCount (in category 'typing/selecting keys') -----
+ tabCount
+ ^ self class autoIndent
+ ifTrue:
+ [ | tabCount s i char |
+ s := paragraph string.
+ i := self stopIndex.
+ tabCount := 0.
+ [(i := i-1) > 0 and: [(char := s at: i) ~= Character cr and: [char ~= Character lf]]]
+ whileTrue: "Count tabs and brackets (but not a leading bracket)"
+ [(char = Character tab and: [i < s size and: [(s at: i+1) ~= $[ ]]) ifTrue: [tabCount := tabCount + 1].
+ char = $[ ifTrue: [tabCount := tabCount + 1].
+ char = $] ifTrue: [tabCount := tabCount - 1]].
+ tabCount ]
+ ifFalse: [ 0 ]!
Item was added:
+ ----- Method: TextEditor>>text (in category 'accessing') -----
+ text
+ "Answer the text of the paragraph being edited."
+
+ ^paragraph text!
Item was added:
+ ----- Method: TextEditor>>totalTextHeight (in category 'accessing') -----
+ totalTextHeight
+
+ ^paragraph lines last bottom!
Item was added:
+ ----- Method: TextEditor>>transformFrom: (in category 'accessing') -----
+ transformFrom: owner
+ ^morph transformFrom: owner!
Item was added:
+ ----- Method: TextEditor>>typeAhead (in category 'private') -----
+ typeAhead
+ ^ typeAhead ifNil:
+ [ self resetTypeAhead.
+ typeAhead ]!
Item was added:
+ ----- Method: TextEditor>>unapplyAttribute: (in category 'private') -----
+ unapplyAttribute: aTextAttribute
+ "The user selected aTextAttribute to be removed.
+ If there is a selection, unapply the attribute to the selection.
+ In any case do not use the attribute for the user input (emphasisHere)"
+
+ | interval |
+
+ emphasisHere := emphasisHere copyWithout: aTextAttribute.
+
+ interval := self selectionInterval.
+ (interval isEmpty and: [ aTextAttribute isParagraphAttribute not ])
+ ifTrue: [ ^self ].
+
+ self text removeAttribute: aTextAttribute from: interval first to: interval last.
+ paragraph recomposeFrom: interval first to: interval last delta: 0.
+ self recomputeSelection. "Needed so visible selection is updated to reflect new visual extent of selection"
+ morph changed!
Item was added:
+ ----- Method: TextEditor>>undo (in category 'menu messages') -----
+ undo
+ "Reset the state of the paragraph prior to the previous edit.
+ If another ParagraphEditor instance did that edit, UndoInterval is invalid;
+ just recover the contents of the undo-buffer at the start of the paragraph."
+
+ self closeTypeIn.
+
+ UndoParagraph == paragraph ifFalse: [ "Can't undo another paragraph's edit"
+ UndoMessage := Message selector: #undoReplace.
+ UndoInterval := 1 to: 0.
+ Undone := true].
+ UndoInterval ~= self selectionInterval ifTrue: [ "blink the actual target"
+ self selectInterval: UndoInterval].
+
+ "Leave a signal of which phase is in progress"
+ UndoParagraph := Undone ifTrue: [#redoing] ifFalse: [#undoing].
+ UndoMessage sentTo: self.
+ UndoParagraph := paragraph!
Item was added:
+ ----- Method: TextEditor>>undo: (in category 'editing keys') -----
+ undo: aKeyboardEvent
+ "Undo the last edit."
+
+ self insertAndCloseTypeIn.
+ self undo.
+ ^true!
Item was added:
+ ----- Method: TextEditor>>undoAgain:andReselect:typedKey: (in category 'undoers') -----
+ undoAgain: indices andReselect: home typedKey: wasTypedKey
+ "The last command was again. Undo it. Redoer: itself."
+
+ | findSize substText |
+ (self isRedoing & wasTypedKey) ifTrue: "redelete search key"
+ [self selectInterval: home.
+ self zapSelectionWith: self nullText].
+
+ findSize := (self isRedoing ifTrue: [FindText] ifFalse: [ChangeText]) size.
+ substText := self isUndoing ifTrue: [FindText] ifFalse: [ChangeText].
+ (self isUndoing ifTrue: [indices size to: 1 by: -1] ifFalse: [1 to: indices size]) do:
+ [:i |
+ | index subject |
+ index := indices at: i.
+ (subject := index to: index + findSize - 1) = self selectionInterval ifFalse:
+ [self selectInterval: subject].
+ FindText == ChangeText ifFalse: [self zapSelectionWith: substText]].
+
+ self isUndoing
+ ifTrue: "restore selection to where it was when 'again' was invoked"
+ [wasTypedKey
+ ifTrue: "search started by typing key at a caret; restore it"
+ [self selectAt: home first.
+ self zapSelectionWith: FindText.
+ self selectAt: home last + 1]
+ ifFalse: [self selectInterval: home]].
+
+ self undoMessage: UndoMessage forRedo: self isUndoing!
Item was added:
+ ----- Method: TextEditor>>undoAndReselect:redoAndReselect: (in category 'undoers') -----
+ undoAndReselect: undoHighlight redoAndReselect: redoHighlight
+ "Undo typing, cancel, paste, and other operations that are like replaces
+ but the selection is not the whole restored text after undo, redo, or both.
+ undoHighlight is selected after this phase and redoHighlight after the next phase.
+ Redoer: itself."
+
+ self replace: self selectionInterval with: UndoSelection and:
+ [self selectInterval: undoHighlight].
+ self undoMessage: (UndoMessage argument: redoHighlight) forRedo: self isUndoing
+ !
Item was added:
+ ----- Method: TextEditor>>undoCutCopy: (in category 'undoers') -----
+ undoCutCopy: oldPasteBuffer
+ "Undo of a cut, copy, or any edit that changed CurrentSelection. Be sure
+ undo-copy does not lock the model. Redoer: itself, so never isRedoing."
+
+ | recentCut |
+ recentCut := self clipboardText.
+ UndoSelection size = UndoInterval size
+ ifFalse: [self replaceSelectionWith: UndoSelection].
+ self clipboardTextPut: oldPasteBuffer.
+ self undoer: #undoCutCopy: with: recentCut!
Item was added:
+ ----- Method: TextEditor>>undoMessage:forRedo: (in category 'undo support') -----
+ undoMessage: aMessage forRedo: aBoolean
+ "Call this from an undoer/redoer to set up UndoMessage as the
+ corresponding redoer/undoer. Also set up UndoParagraph, as well
+ as the state variable Undone. It is assumed that UndoInterval has been
+ established (generally by zapSelectionWith:) and that UndoSelection has been
+ saved (generally by replaceSelectionWith: or replace:With:and:)."
+
+ self isDoing ifTrue: [UndoParagraph := paragraph].
+ UndoMessage := aMessage.
+ Undone := aBoolean!
Item was added:
+ ----- Method: TextEditor>>undoQuery:lastOffering: (in category 'undoers') -----
+ undoQuery: hintText lastOffering: selectorOrNil
+ "Undo ctrl-q. selectorOrNil (if not nil) is the previously offered selector.
+ hintText is the original hint. Redoer: completeSymbol."
+
+ self zapSelectionWith: UndoSelection.
+ self undoMessage: (Message selector: #completeSymbol:lastOffering: arguments: UndoMessage arguments) forRedo: true.
+ self selectAt: self stopIndex!
Item was added:
+ ----- Method: TextEditor>>undoReplace (in category 'undoers') -----
+ undoReplace
+ "Undo of any command that replaced a selection by other text that it left
+ highlighted, and that is undone and redone by simple reversal of the
+ operation. This is the most common Undoer; call replaceSelectionWith:
+ to get this setup. Redoer: itself, so never isRedoing."
+
+ self replaceSelectionWith: UndoSelection!
Item was added:
+ ----- Method: TextEditor>>undoer: (in category 'undo support') -----
+ undoer: aSelector
+ "See comment in undoMessage:. Use this version when aSelector has no arguments, and you are doing or redoing and want to prepare for undoing."
+
+ self undoMessage: (Message selector: aSelector) forRedo: false!
Item was added:
+ ----- Method: TextEditor>>undoer:with: (in category 'undo support') -----
+ undoer: aSelector with: arg1
+ "See comment in undoMessage:. Use this version when aSelector has one argument, and you are doing or redoing and want to prepare for undoing."
+
+ self undoMessage: (Message selector: aSelector argument: arg1) forRedo: false!
Item was added:
+ ----- Method: TextEditor>>undoer:with:with: (in category 'undo support') -----
+ undoer: aSelector with: arg1 with: arg2
+ "See comment in undoMessage:. Use this version when aSelector has two arguments, and you are doing or redoing and want to prepare for undoing."
+
+ self undoMessage: (Message selector: aSelector arguments: (Array with: arg1 with: arg2)) forRedo: false!
Item was added:
+ ----- Method: TextEditor>>undoer:with:with:with: (in category 'undo support') -----
+ undoer: aSelector with: arg1 with: arg2 with: arg3
+ "See comment in undoMessage:. Use this version when aSelector has three arguments, and you are doing or redoing and want to prepare for undoing."
+
+ self undoMessage: (Message selector: aSelector arguments: (Array with: arg1 with: arg2 with: arg3)) forRedo: false!
Item was added:
+ ----- Method: TextEditor>>unselect (in category 'accessing-selection') -----
+ unselect
+ markBlock := pointBlock copy!
Item was added:
+ ----- Method: TextEditor>>updateMarker (in category 'scrolling') -----
+ updateMarker
+ "Ignore scrollbar redraw requests."
+ !
Item was added:
+ ----- Method: TextEditor>>visibleHeight (in category 'accessing') -----
+ visibleHeight
+
+ ^morph owner bounds height!
Item was added:
+ ----- Method: TextEditor>>yellowButtonDown: (in category 'events') -----
+ yellowButtonDown: event
+ "Process a yellow button event. Answer true if the event was handled, false otherwise."
+ (paragraph attributesAt: event cursorPoint) do:[:attr|
+ attr menu ifNotNil:[
+ attr menu openAt: event cursorPoint.
+ ^true]].
+ ^false!
Item was added:
+ ----- Method: TextEditor>>zapSelectionWith: (in category 'mvc compatibility') -----
+ zapSelectionWith: replacement
+
+ | start stop rep |
+ self deselect.
+ start := self startIndex.
+ stop := self stopIndex.
+ (replacement isEmpty and: [stop > start]) ifTrue: [
+ "If deleting, then set emphasisHere from 1st character of the deletion"
+ emphasisHere := (self text attributesAt: start) select: [:att | att mayBeExtended]].
+ (start = stop and: [ replacement isEmpty ]) ifFalse: [
+ replacement isText
+ ifTrue: [ rep := replacement]
+ ifFalse: [ rep := Text string: replacement attributes: emphasisHere ].
+ self text replaceFrom: start to: stop - 1 with: rep.
+ paragraph
+ recomposeFrom: start
+ to: start + rep size - 1
+ delta: rep size - (stop-start).
+ self markIndex: start pointIndex: start + rep size.
+ UndoInterval := otherInterval := self selectionInterval].
+
+ self userHasEdited " -- note text now dirty"!
Item was added:
+ RectangleMorph subclass: #TextFieldMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !TextFieldMorph commentStamp: '<historical>' prior: 0!
+ Act as a field in a HyperCard-like setting. Has both properties of a Rectangle, and exposes some proteries of the TextMorph it owns.
+
+ !
Item was added:
+ ----- Method: TextFieldMorph class>>authoringPrototype (in category 'scripting') -----
+ authoringPrototype
+ "Answer an instance of the receiver that can serve as a prototype for authoring"
+
+ | proto |
+ proto := super authoringPrototype.
+ proto setProperty: #shared toValue: true.
+ proto extent: 170 @ 30.
+ proto color: Color veryLightGray lighter.
+ proto contents: 'on a clear day you can...'.
+ ^ proto
+ !
Item was added:
+ ----- Method: TextFieldMorph class>>initialize (in category 'class initialization') -----
+ initialize
+
+ self registerInFlapsRegistry. !
Item was added:
+ ----- Method: TextFieldMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
+ registerInFlapsRegistry
+ "Register the receiver in the system's flaps registry"
+ self environment
+ at: #Flaps
+ ifPresent: [:cl | cl registerQuad: #(TextFieldMorph exampleBackgroundField 'Scrolling Field' 'A scrolling data field which will have a different value on every card of the background')
+ forFlapNamed: 'Scripting'.]!
Item was added:
+ ----- Method: TextFieldMorph class>>unload (in category 'class initialization') -----
+ unload
+ "Unload the receiver from global registries"
+
+ self environment at: #Flaps ifPresent: [:cl |
+ cl unregisterQuadsWithReceiver: self] !
Item was added:
+ ----- Method: TextFieldMorph>>append: (in category 'just like textMorph') -----
+ append: stringOrText
+ "add to my text"
+ | tm |
+
+ (tm := self findA: TextMorph) ifNil: [^ nil].
+ tm contents append: stringOrText.
+ tm releaseParagraph; paragraph.
+
+
+ !
Item was added:
+ ----- Method: TextFieldMorph>>contents (in category 'just like textMorph') -----
+ contents
+ | tm |
+ "talk to my text"
+
+ (tm := self findA: TextMorph) ifNil: [^ nil].
+ ^ tm contents!
Item was added:
+ ----- Method: TextFieldMorph>>contents: (in category 'just like textMorph') -----
+ contents: textOrString
+ "talk to my text"
+ | tm newText atts |
+
+ (tm := self findA: TextMorph) ifNil: [^ nil].
+ textOrString isString ifTrue: [
+ tm contents ifNotNil: ["Keep previous properties of the field"
+ newText := textOrString asText.
+ atts := tm contents attributesAt: 1.
+ atts do: [:each | newText addAttribute: each].
+ ^ tm contents: newText]].
+
+ ^ tm contents: textOrString!
Item was added:
+ ----- Method: TextFieldMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color veryLightGray lighter!
Item was added:
+ ----- Method: TextFieldMorph>>fit (in category 'just like textMorph') -----
+ fit
+ "tell my text to recompute its looks"
+ | tm |
+
+ (tm := self findA: TextMorph) ifNil: [^ nil].
+ tm releaseParagraph; paragraph.!
Item was added:
+ ----- Method: TextFieldMorph>>fontName:size: (in category 'just like textMorph') -----
+ fontName: fontName size: fontSize
+ | tm |
+ "talk to my text"
+
+ (tm := self findA: TextMorph) ifNil: [^ nil].
+ ^ tm fontName: fontName size: fontSize
+ !
Item was added:
+ ----- Method: TextFieldMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ | tm |
+ super initialize.
+ ""
+
+ self addMorph: (tm := TextMorph new).
+ tm fillingOnOff!
Item was added:
+ ----- Method: TextFieldMorph>>lineCount (in category 'just like textMorph') -----
+ lineCount
+ | tm |
+ "how many lines in my text"
+
+ (tm := self findA: TextMorph) ifNil: [^ nil].
+ ^ tm contents string lineCount!
Item was added:
+ ----- Method: TextFieldMorph>>prepend: (in category 'just like textMorph') -----
+ prepend: stringOrText
+ "add to my text"
+ | tm |
+
+ (tm := self findA: TextMorph) ifNil: [^ nil].
+ tm contents prepend: stringOrText.
+ tm releaseParagraph; paragraph.
+
+
+ !
Item was added:
+ RectangleMorph subclass: #TextMorph
+ instanceVariableNames: 'textStyle text wrapFlag paragraph editor container predecessor successor backgroundColor margins editHistory'
+ classVariableNames: 'CaretForm DefaultEditorClass'
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !TextMorph commentStamp: 'nice 3/24/2010 07:40' prior: 0!
+ TextMorphs support display of text with emphasis. They also support reasonable text-editing capabilities, as well as embedded hot links, and the ability to embed submorphs in the text.
+
+ Late in life, TextMorph was made a subclass of BorderedMorph to provide border and background color if desired. In order to keep things compatible, protocols have been redirected so that color (preferably textColor) relates to the text, and backgroundColor relates to the inner fill color.
+
+ Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter.
+
+ If text has been embedded in another object, one can elect to fill the owner's shape, in which case the text will be laid out in the shape of the owner's shadow image (including any submorphs other than the text). One can also elect to have the text avoid occlusions, in which case it will avoid the bounds of any sibling morphs that appear in front of it. It may be necessary to update bounds in order for the text runaround to notice the presence of a new occluding shape.
+
+ The optional autoFitContents property enables the following feature: if the text contents changes, then the bounds of the morph will be adjusted to fit the minimum rectangle that encloses the text (plus any margins specified). Similarly, any attempt to change the size of the morph will be resisted if this parameter is set. Except...
+
+ If the wrapFlag parameter is true, then text will be wrapped at word boundaries based on the composition width (innerBounds insetBy: margins) width. Thus an attempt to resize the morph in autofit mode, if it changes the width, will cause the text to be recomposed with the new width, and then the bounds will be reset to the minimum enclosing rectangle. Similarly, if the text contents are changed with the wrapFlag set to true, word wrap will be performed based on the current compostion width, after which the bounds will be set (or not), based on the autoFitcontents property.
+
+ Note that fonts can only be applied to the TextMorph as a whole. While you can change the size, color, and emphasis of a subsection of the text and have it apply to only that subsection, changing the font changes the font for the entire contents of the TextMorph.
+
+ Still a TextMorph can be composed of several texts of different fonts
+ | font1 font2 t1 t2 tMorph|
+ tMorph := TextMorph new.
+ font1 := (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 22)).
+ font2 := (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 11)).
+ t1 := 'this is font1' asText addAttribute: font1.
+ t2 := ' and this is font2' asText addAttribute: font2.
+ tMorph contents: (t1,t2).
+ tMorph openInHand.
+
+
+ Yet to do:
+ Make a comprehensive control for the eyedropper, with border width and color, inner color and text color, and margin widths.!
Item was added:
+ ----- Method: TextMorph class>>authoringPrototype (in category 'scripting') -----
+ authoringPrototype
+ | t |
+ t := super authoringPrototype.
+ t contents: 'abc' translated asText.
+ t wrapFlag: true.
+
+ "Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window"
+ t paragraph.
+ ^ t!
Item was added:
+ ----- Method: TextMorph class>>boldAuthoringPrototype (in category 'connectorstext-parts bin') -----
+ boldAuthoringPrototype
+ "TextMorph boldAuthoringPrototype openInHand"
+ | text |
+ text := Text string: 'Text' translated attributes: { TextEmphasis bold. }.
+ ^self new
+ contentsWrapped: text;
+ fontName: 'BitstreamVeraSans' pointSize: 24;
+ paragraph;
+ extent: 79 at 36;
+ margins: 4 at 0;
+ fit;
+ yourself
+ !
Item was added:
+ ----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') -----
+ borderedPrototype
+
+ | t |
+ t := self authoringPrototype.
+ t fontName: 'BitstreamVeraSans' pointSize: 24.
+ t autoFit: false; extent: 250 at 100.
+ t borderWidth: 1; margins: 4 at 0.
+
+ "Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window"
+ t paragraph.
+ ^ t!
Item was added:
+ ----- Method: TextMorph class>>defaultEditorClass (in category 'class initialization') -----
+ defaultEditorClass
+ "Answers the default editor class for TextMorph"
+ ^DefaultEditorClass!
Item was added:
+ ----- Method: TextMorph class>>defaultEditorClass: (in category 'class initialization') -----
+ defaultEditorClass: aTextEditorClass
+ "Sets the default editor class for TextMorph"
+ "
+ TextMorph defaultEditorClass: TextMorphEditor.
+ TextMorph defaultEditorClass: TextEditor.
+ "
+ DefaultEditorClass := aTextEditorClass!
Item was added:
+ ----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') -----
+ defaultNameStemForInstances
+ ^ 'Text'!
Item was added:
+ ----- Method: TextMorph class>>exampleBackgroundLabel (in category 'parts bin') -----
+ exampleBackgroundLabel
+ "Answer a background label for a parts bin"
+
+ | aTextMorph |
+ aTextMorph := self authoringPrototype.
+ aTextMorph contents: 'background
+ label' asText.
+ aTextMorph beAllFont: (StrikeFont familyName: #NewYork size: 18).
+ aTextMorph color: Color brown.
+ aTextMorph setProperty: #shared toValue: true.
+ ^ aTextMorph
+ !
Item was added:
+ ----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') -----
+ fancyPrototype
+
+ | t |
+ t := self authoringPrototype.
+ t autoFit: false; extent: 150 at 75.
+ t borderWidth: 2; margins: 4 at 0; useRoundedCorners. "Why not rounded?"
+ "fancy font, shadow, rounded"
+ t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; backgroundColor: Color lightBrown.
+ t addDropShadow.
+
+ "Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window"
+ t paragraph.
+ ^ t!
Item was added:
+ ----- Method: TextMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ ^ true!
Item was added:
+ ----- Method: TextMorph class>>initialize (in category 'class initialization') -----
+ initialize "TextMorph initialize"
+
+ "Initialize the default text editor class to use"
+ DefaultEditorClass := SmalltalkEditor.
+
+ "Initialize constants shared by classes associated with text display."
+
+ CaretForm := (ColorForm extent: 16 at 5
+ fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26)
+ offset: -2 at 0)
+ colors: (Array with: Color transparent with: Preferences textHighlightColor).
+
+ self registerInFlapsRegistry.
+ !
Item was added:
+ ----- Method: TextMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
+ registerInFlapsRegistry
+ "Register the receiver in the system's flaps registry"
+ self environment
+ at: #Flaps
+ ifPresent: [:cl | cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
+ forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: #(TextMorph exampleBackgroundLabel 'Background Label' 'A piece of text that will occur on every card of the background')
+ forFlapNamed: 'Scripting'.
+ cl registerQuad: #(TextMorph exampleBackgroundField 'Background Field' 'A data field which will have a different value on every card of the background')
+ forFlapNamed: 'Scripting'.
+ cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish')
+ forFlapNamed: 'Stack Tools'.
+ cl registerQuad: #(TextMorph fancyPrototype 'Fancy Text' 'A text field with a rounded shadowed border, with a fancy font.')
+ forFlapNamed: 'Stack Tools'.
+ cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
+ forFlapNamed: 'Supplies'.]!
Item was added:
+ ----- Method: TextMorph class>>unload (in category 'class initialization') -----
+ unload
+ "Unload the receiver from global registries"
+
+ self environment at: #Flaps ifPresent: [:cl |
+ cl unregisterQuadsWithReceiver: self] !
Item was added:
+ ----- Method: TextMorph>>acceptContents (in category 'editing') -----
+ acceptContents
+ "The message is sent when the user hits enter or Cmd-S.
+ Accept the current contents and end editing.
+ This default implementation does nothing."
+ self updateFromParagraph!
Item was added:
+ ----- Method: TextMorph>>acceptDroppingMorph:event: (in category 'layout') -----
+ acceptDroppingMorph: aMorph event: evt
+ "This message is sent when a morph is dropped onto me."
+
+ self addMorphFront: aMorph fromWorldPosition: aMorph position.
+ "Make a TextAnchor and install it in a run."!
Item was added:
+ ----- Method: TextMorph>>acceptOnCR (in category 'editing') -----
+ acceptOnCR
+ "Answer whether the receiver wants to accept when the Return key is hit. Generic TextMorph has no such feature, but subclasses may."
+
+ ^ false!
Item was added:
+ ----- Method: TextMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ | outer |
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ aCustomMenu add: 'text properties...' translated action: #changeTextColor.
+ aCustomMenu addUpdating: #autoFitString target: self action: #autoFitOnOff.
+ aCustomMenu addUpdating: #wrapString target: self action: #wrapOnOff.
+ aCustomMenu add: 'text margins...' translated action: #changeMargins:.
+ aCustomMenu add: 'add predecessor' translated action: #addPredecessor:.
+ aCustomMenu add: 'add successor' translated action: #addSuccessor:.
+
+ outer := self owner.
+ outer ifNotNil: [
+ outer isLineMorph ifTrue:
+ [container isNil
+ ifTrue: [Smalltalk at: #TextOnCurveContainer ifPresent: [:ignored | aCustomMenu add: 'follow owner''s curve' translated action: #followCurve]]
+ ifFalse: [aCustomMenu add: 'reverse direction' translated action: #reverseCurveDirection.
+ aCustomMenu add: 'set baseline' translated action: #setCurveBaseline:]]
+ ifFalse:
+ [self fillsOwner
+ ifFalse: [aCustomMenu add: 'fill owner''s shape' translated action: #fillingOnOff]
+ ifTrue: [aCustomMenu add: 'rectangular bounds' translated action: #fillingOnOff].
+ self avoidsOcclusions
+ ifFalse: [aCustomMenu add: 'avoid occlusions' translated action: #occlusionsOnOff]
+ ifTrue: [aCustomMenu add: 'ignore occlusions' translated action: #occlusionsOnOff]]].
+ aCustomMenu addLine.
+ aCustomMenu add: 'holder for characters' translated action: #holderForCharacters
+ !
Item was added:
+ ----- Method: TextMorph>>addMorphFront:fromWorldPosition: (in category 'submorphs-add/remove') -----
+ addMorphFront: aMorph fromWorldPosition: wp
+ "Overridden for more specific re-layout and positioning"
+ aMorph textAnchorType == #document
+ ifFalse:[^self anchorMorph: aMorph at: wp type: aMorph textAnchorType].
+ self addMorphFront: aMorph.
+ !
Item was added:
+ ----- Method: TextMorph>>addPredecessor: (in category 'linked frames') -----
+ addPredecessor: evt
+ | newMorph |
+ newMorph := self copy predecessor: predecessor successor: self.
+ newMorph extent: self width @ 100.
+ predecessor ifNotNil: [predecessor setSuccessor: newMorph].
+ self setPredecessor: newMorph.
+ predecessor recomposeChain.
+ evt hand attachMorph: newMorph!
Item was added:
+ ----- Method: TextMorph>>addSuccessor: (in category 'linked frames') -----
+ addSuccessor: evt
+ | newMorph |
+ newMorph := self copy predecessor: self successor: successor.
+ newMorph extent: self width @ 100.
+ successor ifNotNil: [successor setPredecessor: newMorph].
+ self setSuccessor: newMorph.
+ successor recomposeChain.
+ evt hand attachMorph: newMorph!
Item was added:
+ ----- Method: TextMorph>>adjustLineIndicesBy: (in category 'private') -----
+ adjustLineIndicesBy: delta
+ paragraph ifNotNil: [paragraph adjustLineIndicesBy: delta]!
Item was added:
+ ----- Method: TextMorph>>adjustTextAnchor: (in category 'anchors') -----
+ adjustTextAnchor: aMorph
+ "Later compute the new relative position of aMorph if it is #paragraph anchored."!
Item was added:
+ ----- Method: TextMorph>>anchorMorph:at:type: (in category 'anchors') -----
+ anchorMorph: aMorph at: aPoint type: anchorType
+ | relPt index newText block |
+ aMorph owner == self ifTrue:[self removeMorph: aMorph].
+ aMorph textAnchorType: nil.
+ aMorph relativeTextAnchorPosition: nil.
+ self addMorphFront: aMorph.
+ aMorph textAnchorType: anchorType.
+ aMorph relativeTextAnchorPosition: nil.
+ anchorType == #document ifTrue:[^self].
+ relPt := self transformFromWorld globalPointToLocal: aPoint.
+ index := (self paragraph characterBlockAtPoint: relPt) stringIndex.
+ newText := Text string: (String value: 1) attribute: (TextAnchor new anchoredMorph: aMorph).
+ anchorType == #inline ifTrue:[
+ self paragraph replaceFrom: index to: index-1 with: newText displaying: false.
+ ] ifFalse:[
+ index := index min: paragraph text size.
+ index := paragraph text string lastIndexOf: Character cr startingAt: index ifAbsent:[0].
+ block := paragraph characterBlockForIndex: index+1.
+ aMorph relativeTextAnchorPosition: (relPt x - bounds left) @ (relPt y - block top ).
+ self paragraph replaceFrom: index+1 to: index with: newText displaying: false.
+ ].
+ self fit.!
Item was added:
+ ----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') -----
+ areasRemainingToFill: aRectangle
+ "Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+ (backgroundColor isNil or: [backgroundColor isTranslucent])
+ ifTrue: [^ Array with: aRectangle].
+ self wantsRoundedCorners
+ ifTrue: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]])
+ ifTrue: [^ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners)]
+ ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]]
+ ifFalse: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]])
+ ifTrue: [^ aRectangle areasOutside: self innerBounds]
+ ifFalse: [^ aRectangle areasOutside: self bounds]]!
Item was added:
+ ----- Method: TextMorph>>asText (in category 'accessing') -----
+ asText
+ ^ text!
Item was added:
+ ----- Method: TextMorph>>autoFit: (in category 'accessing') -----
+ autoFit: trueOrFalse
+ "Whether I automatically adjust my size to fit text as it changes"
+
+ self isAutoFit = trueOrFalse ifTrue: [^ self].
+ self autoFitOnOff.!
Item was added:
+ ----- Method: TextMorph>>autoFitOnOff (in category 'menu') -----
+ autoFitOnOff
+ self setProperty: #autoFitContents toValue: self isAutoFit not.
+ self isAutoFit ifTrue: [self fit]!
Item was added:
+ ----- Method: TextMorph>>autoFitString (in category 'menu') -----
+ autoFitString
+ "Answer the string to put in a menu that will invite the user to
+ switch autoFit mode"
+ ^ (self isAutoFit
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ , 'text auto fit' translated!
Item was added:
+ ----- Method: TextMorph>>avoidsOcclusions (in category 'containment') -----
+ avoidsOcclusions
+ ^container notNil and: [ container avoidsOcclusions ]
+ !
Item was added:
+ ----- Method: TextMorph>>backgroundColor (in category 'accessing') -----
+ backgroundColor
+ ^ backgroundColor!
Item was added:
+ ----- Method: TextMorph>>backgroundColor: (in category 'accessing') -----
+ backgroundColor: newColor
+ backgroundColor := newColor.
+ self changed!
Item was added:
+ ----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
+ beAllFont: aFont
+
+ textStyle := TextStyle fontArray: (Array with: aFont).
+ self releaseCachedState; changed!
Item was added:
+ ----- Method: TextMorph>>blinkStart (in category 'blinking') -----
+ blinkStart
+ "Reset time for blink cursor after which blinking should actually start"
+ ^self valueOfProperty: #blinkStart ifAbsent:[Time millisecondClockValue]
+ !
Item was added:
+ ----- Method: TextMorph>>blinkStart: (in category 'blinking') -----
+ blinkStart: msecs
+ "Reset time for blink cursor after which blinking should actually start"
+ ^self setProperty: #blinkStart toValue: msecs
+ !
Item was added:
+ ----- Method: TextMorph>>borderWidth: (in category 'accessing') -----
+ borderWidth: newWidth
+ super borderWidth: newWidth.
+ paragraph ifNotNil: [self composeToBounds].!
Item was added:
+ ----- Method: TextMorph>>bounds (in category 'geometry') -----
+ bounds
+ container ifNil: [^ bounds].
+ ^ container bounds ifNil: [bounds]!
Item was added:
+ ----- Method: TextMorph>>cancelEdits (in category 'editing') -----
+ cancelEdits
+ "The message is sent when the user hits enter or Cmd-L.
+ Cancel the current contents and end editing.
+ This default implementation does nothing."
+ self releaseParagraph!
Item was added:
+ ----- Method: TextMorph>>centered (in category 'alignment') -----
+ centered
+ self paragraph centered.
+ self updateFromParagraph !
Item was added:
+ ----- Method: TextMorph>>changeMargins: (in category 'menu') -----
+ changeMargins: evt
+ | handle origin aHand oldMargin newMargin |
+ aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand].
+ origin := aHand position.
+ oldMargin := margins.
+ (handle := HandleMorph new)
+ forEachPointDo:
+ [:newPoint | handle removeAllMorphs.
+ handle addMorph:
+ (LineMorph from: origin to: newPoint color: Color black width: 1).
+ newMargin := (newPoint - origin max: 0 at 0) // 5.
+ self margins: newMargin]
+ lastPointDo:
+ [:newPoint | handle deleteBalloon.
+ self halo ifNotNil: [ :halo | halo addHandles].
+ self rememberCommand:
+ (Command new cmdWording: ('margin change for ' translated,self nameForUndoWording);
+ undoTarget: self selector: #margins: argument: oldMargin;
+ redoTarget: self selector: #margins: argument: newMargin;
+ yourself)].
+ aHand attachMorph: handle.
+ handle setProperty: #helpAtCenter toValue: true.
+ handle showBalloon:
+ 'Move cursor down and to the right
+ to increase margin inset.
+ Click when done.' hand: evt hand.
+ handle startStepping!
Item was added:
+ ----- Method: TextMorph>>changeTextColor (in category 'menu') -----
+ changeTextColor
+ "Change the color of the receiver -- triggered, e.g. from a menu"
+
+ self openATextPropertySheet.
+ ">>>>>
+ ColorPickerMorph new
+ choseModalityFromPreference;
+ sourceHand: self activeHand;
+ target: self;
+ selector: #textColor:;
+ originalColor: self textColor;
+ putUpFor: self near: self fullBoundsInWorld
+ <<<<"!
Item was added:
+ ----- Method: TextMorph>>chooseAlignment (in category 'editing') -----
+ chooseAlignment
+ self editor changeAlignment.
+ self updateFromParagraph!
Item was added:
+ ----- Method: TextMorph>>chooseEmphasis (in category 'editing') -----
+ chooseEmphasis
+ self editor changeEmphasis.
+ self updateFromParagraph!
Item was added:
+ ----- Method: TextMorph>>chooseEmphasisOrAlignment (in category 'editing') -----
+ chooseEmphasisOrAlignment
+ self editor changeEmphasisOrAlignment.
+ self updateFromParagraph!
Item was added:
+ ----- Method: TextMorph>>chooseFont (in category 'editing') -----
+ chooseFont
+ self editor changeTextFont.
+ self updateFromParagraph.!
Item was added:
+ ----- Method: TextMorph>>chooseStyle (in category 'editing') -----
+ chooseStyle
+ self editor changeStyle.
+ self updateFromParagraph.!
Item was added:
+ ----- Method: TextMorph>>clippingRectangle (in category 'private') -----
+ clippingRectangle
+ ^ self innerBounds!
Item was added:
+ ----- Method: TextMorph>>composeToBounds (in category 'private') -----
+ composeToBounds
+ "Compose my text to fit my bounds.
+ If any text lies outside my bounds, it will be clipped, or
+ if I have successors, it will be shown in the successors."
+ | |
+ self releaseParagraph; paragraph.
+ container ifNotNil:
+ [self privateBounds: container bounds truncated].
+ self paragraph positionWhenComposed: self position.
+ successor ifNotNil:
+ [successor predecessorChanged].
+
+ !
Item was added:
+ ----- Method: TextMorph>>compositionRectangle (in category 'private') -----
+ compositionRectangle
+ | compRect |
+ compRect := self innerBounds.
+ margins ifNotNil: [compRect := compRect insetBy: margins].
+ compRect width < 9 ifTrue: [compRect := compRect withWidth: 9].
+ compRect height < 16 ifTrue: [compRect := compRect withHeight: 16].
+ ^ compRect!
Item was added:
+ ----- Method: TextMorph>>container (in category 'geometry') -----
+ container
+ "Return the container for composing this text. There are four cases:
+ 1. container is specified as, eg, an arbitrary shape,
+ 2. container is specified as the bound rectangle, because
+ this morph is linked to others,
+ 3. container is nil, and wrap is true -- grow downward as necessary,
+ 4. container is nil, and wrap is false -- grow in 2D as nexessary."
+
+ container ifNil:
+ [successor ifNotNil: [^ self compositionRectangle].
+ wrapFlag ifTrue: [^ self compositionRectangle withHeight: 9999999].
+ ^ self compositionRectangle topLeft extent: 9999999 at 9999999].
+ ^ container!
Item was added:
+ ----- Method: TextMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+ (super containsPoint: aPoint) ifFalse: [^ false]. "Not in my bounds"
+ container ifNil: [^ true]. "In bounds of simple text"
+ self startingIndex > text size ifTrue:
+ ["make null text frame visible"
+ ^ super containsPoint: aPoint].
+ "In complex text (non-rect container), test by line bounds"
+ ^ self paragraph containsPoint: aPoint
+ !
Item was added:
+ ----- Method: TextMorph>>contents (in category 'accessing') -----
+ contents
+
+ ^ text!
Item was added:
+ ----- Method: TextMorph>>contents: (in category 'accessing') -----
+ contents: stringOrText
+ ^ self contentsAsIs: stringOrText!
Item was added:
+ ----- Method: TextMorph>>contents:wrappedTo: (in category 'accessing') -----
+ contents: stringOrText wrappedTo: width
+ "Accept new text contents. Lay it out, wrapping to width.
+ Then fit my height to the result."
+ self newContents: ''.
+ wrapFlag := true.
+ super extent: width truncated at self height.
+ self newContents: stringOrText!
Item was added:
+ ----- Method: TextMorph>>contentsAsIs: (in category 'accessing') -----
+ contentsAsIs: stringOrText
+ "Accept new text contents with line breaks only as in the text.
+ Fit my width and height to the result."
+ wrapFlag := false.
+ container ifNotNil: [container fillsOwner ifTrue: [wrapFlag := true]].
+ self newContents: stringOrText!
Item was added:
+ ----- Method: TextMorph>>contentsWrapped: (in category 'accessing') -----
+ contentsWrapped: stringOrText
+ "Accept new text contents. Lay it out, wrapping within my current width.
+ Then fit my height to the result."
+ wrapFlag := true.
+ self newContents: stringOrText!
Item was added:
+ ----- Method: TextMorph>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ borderWidth ifNil:
+ [borderWidth := 0.
+ self removeProperty: #fillStyle].
+ ^ super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: TextMorph>>copy (in category 'copying') -----
+ copy
+ ^ super copy text: text copy textStyle: textStyle copy
+ wrap: wrapFlag color: color
+ predecessor: nil successor: nil!
Item was added:
+ ----- Method: TextMorph>>crAction (in category 'accessing') -----
+ crAction
+ "Return the action to perform when encountering a CR in the input"
+ ^self valueOfProperty: #crAction!
Item was added:
+ ----- Method: TextMorph>>crAction: (in category 'accessing') -----
+ crAction: aMessageSend
+ "Return the action to perform when encountering a CR in the input"
+ ^self setProperty: #crAction toValue: aMessageSend!
Item was added:
+ ----- Method: TextMorph>>cursor (in category 'accessing') -----
+ cursor
+ "Answer the receiver's logical cursor position"
+
+ | loc |
+ loc := self valueOfProperty: #textCursorLocation ifAbsentPut: [1].
+ loc := loc min: text string size.
+ ^ loc rounded
+ !
Item was added:
+ ----- Method: TextMorph>>cursorWrapped: (in category 'accessing') -----
+ cursorWrapped: aNumber
+ "Set the cursor as indicated"
+
+ self setProperty: #textCursorLocation toValue: (((aNumber rounded - 1) \\ text string size) + 1)
+
+ !
Item was added:
+ ----- Method: TextMorph>>debugDrawLineRectsOn: (in category 'drawing') -----
+ debugDrawLineRectsOn: aCanvas
+ "Shows where text line rectangles are"
+ self paragraph lines do:
+ [:line | aCanvas frameRectangle: line rectangle color: Color brown]
+ !
Item was added:
+ ----- Method: TextMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color black!
Item was added:
+ ----- Method: TextMorph>>defaultLineHeight (in category 'geometry') -----
+ defaultLineHeight
+ ^ textStyle lineGrid!
Item was added:
+ ----- Method: TextMorph>>delete (in category 'submorphs-add/remove') -----
+ delete
+ predecessor ifNotNil: [predecessor setSuccessor: successor].
+ successor ifNotNil: [successor setPredecessor: predecessor.
+ successor recomposeChain].
+ super delete!
Item was added:
+ ----- Method: TextMorph>>drawNullTextOn: (in category 'drawing') -----
+ drawNullTextOn: aCanvas
+ "make null text frame visible"
+
+ aCanvas isPostscriptCanvas ifFalse: [
+ aCanvas fillRectangle: bounds color:
+ ((Color black) alpha: 0.1).
+ ]!
Item was added:
+ ----- Method: TextMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ "Draw the receiver on a canvas"
+
+ | fauxBounds |
+ self setDefaultContentsIfNil.
+ super drawOn: aCanvas. "Border and background if any"
+ false ifTrue: [self debugDrawLineRectsOn: aCanvas]. "show line rects for debugging"
+ (self startingIndex > text size)
+ ifTrue: [self drawNullTextOn: aCanvas].
+ "Hack here: The canvas expects bounds to carry the location of the text, but we also need to communicate clipping."
+ fauxBounds := self bounds topLeft corner: self innerBounds bottomRight.
+ aCanvas paragraph: self paragraph bounds: fauxBounds color: color!
Item was added:
+ ----- Method: TextMorph>>editHistory (in category 'multi level undo') -----
+ editHistory
+ editHistory ifNil: [ editHistory := TextMorphCommandHistory new].
+ ^editHistory
+ !
Item was added:
+ ----- Method: TextMorph>>editHistory: (in category 'multi level undo') -----
+ editHistory: aTextMorphCommandHistory
+ ^editHistory := aTextMorphCommandHistory
+ !
Item was added:
+ ----- Method: TextMorph>>editor (in category 'accessing') -----
+ editor
+ "Return my current editor, or install a new one."
+ editor ifNotNil: [^ editor].
+ ^ self installEditorToReplace: nil!
Item was added:
+ ----- Method: TextMorph>>editorClass (in category 'private') -----
+ editorClass
+ "Answer the class used to create the receiver's editor"
+ ^DefaultEditorClass!
Item was added:
+ ----- Method: TextMorph>>elementCount (in category 'accessing') -----
+ elementCount
+ "Answer how many sub-objects are within me"
+
+ ^ self text string size !
Item was added:
+ ----- Method: TextMorph>>enterClickableRegion: (in category 'editing') -----
+ enterClickableRegion: evt
+ | index isLink |
+ evt hand hasSubmorphs ifTrue:[^self].
+ evt hand temporaryCursor ifNotNil:[^self].
+ paragraph ifNotNil:[
+ index := (paragraph characterBlockAtPoint: evt position) stringIndex.
+ isLink := (paragraph text attributesAt: index forStyle: paragraph textStyle)
+ anySatisfy:[:attr| attr mayActOnClick].
+ isLink ifTrue:[Cursor webLink show] ifFalse:[Cursor normal show].
+ ].
+ !
Item was added:
+ ----- Method: TextMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ | newExtent priorEditor |
+ bounds extent = aPoint ifTrue: [^ self].
+ priorEditor := editor.
+ self isAutoFit
+ ifTrue: [wrapFlag ifFalse: [^ self]. "full autofit can't change"
+ newExtent := aPoint truncated max: self minimumExtent.
+ newExtent x = self extent x ifTrue: [^ self]. "No change of wrap width"
+ self releaseParagraphReally. "invalidate the paragraph cache"
+ super extent: newExtent.
+ priorEditor
+ ifNil: [self fit] "since the width has changed..."
+ ifNotNil: [self installEditorToReplace: priorEditor]]
+ ifFalse: [super extent: (aPoint truncated max: self minimumExtent).
+ wrapFlag ifFalse: [^ self]. "no effect on composition"
+ self composeToBounds]
+ !
Item was added:
+ ----- Method: TextMorph>>fillStyle (in category 'visual properties') -----
+ fillStyle
+ "Return the current fillStyle of the receiver."
+ ^ self
+ valueOfProperty: #fillStyle
+ ifAbsent: [backgroundColor
+ ifNil: [Color transparent]]!
Item was added:
+ ----- Method: TextMorph>>fillStyle: (in category 'visual properties') -----
+ fillStyle: aFillStyle
+ "Set the current fillStyle of the receiver."
+ self setProperty: #fillStyle toValue: aFillStyle.
+ "Workaround for Morphs not yet converted"
+ backgroundColor := aFillStyle asColor.
+ self changed.!
Item was added:
+ ----- Method: TextMorph>>fillingOnOff (in category 'containment') -----
+ fillingOnOff
+ "Establish a container for this text, with opposite filling status"
+ self fillsOwner: (self fillsOwner not)!
Item was added:
+ ----- Method: TextMorph>>fillsOwner (in category 'containment') -----
+ fillsOwner
+ "Answer true if I fill my owner's shape."
+ ^container notNil and: [container fillsOwner]!
Item was added:
+ ----- Method: TextMorph>>fillsOwner: (in category 'containment') -----
+ fillsOwner: aBoolean
+ self fillsOwner == aBoolean
+ ifTrue: [^ self].
+ self
+ setContainer: (aBoolean
+ ifTrue: [wrapFlag := true.
+ container
+ ifNil: [TextContainer new for: self minWidth: textStyle lineGrid * 2]
+ ifNotNil: [container fillsOwner: true]]
+ ifFalse: [self avoidsOcclusions
+ ifFalse: [ nil ]
+ ifTrue: [container fillsOwner: false]])!
Item was added:
+ ----- Method: TextMorph>>firstCharacterIndex (in category 'linked frames') -----
+ firstCharacterIndex
+ ^ self paragraph firstCharacterIndex!
Item was added:
+ ----- Method: TextMorph>>firstInChain (in category 'linked frames') -----
+ firstInChain
+ "Return the first morph in a chain of textMorphs"
+
+ | first |
+ first := self.
+ [first predecessor isNil] whileFalse: [first := first predecessor].
+ ^first!
Item was added:
+ ----- Method: TextMorph>>fit (in category 'private') -----
+ fit
+ "Adjust my bounds to fit the text. Should be a no-op if autoFit is not specified.
+ Required after the text changes,
+ or if wrapFlag is true and the user attempts to change the extent."
+
+ | newExtent para cBounds lastOfLines heightOfLast |
+ self isAutoFit
+ ifTrue:
+ [newExtent := (self paragraph extent max: 9 @ textStyle lineGrid) + (0 @ 2).
+ newExtent := newExtent + (2 * borderWidth).
+ margins
+ ifNotNil: [newExtent := ((0 @ 0 extent: newExtent) expandBy: margins) extent].
+ newExtent ~= bounds extent
+ ifTrue:
+ [(container isNil and: [successor isNil])
+ ifTrue:
+ [para := paragraph. "Save para (layoutChanged smashes it)"
+ super extent: newExtent.
+ paragraph := para]].
+ container notNil & successor isNil
+ ifTrue:
+ [cBounds := container bounds truncated.
+ "23 sept 2000 - try to allow vertical growth"
+ lastOfLines := self paragraph lines last.
+ heightOfLast := lastOfLines bottom - lastOfLines top.
+ (lastOfLines last < text size
+ and: [lastOfLines bottom + heightOfLast >= self bottom])
+ ifTrue:
+ [container releaseCachedState.
+ cBounds := cBounds origin corner: cBounds corner + (0 @ heightOfLast)].
+ self privateBounds: cBounds]].
+
+ "These statements should be pushed back into senders"
+ self paragraph positionWhenComposed: self position.
+ successor ifNotNil: [successor predecessorChanged].
+ self changed "Too conservative: only paragraph composition
+ should cause invalidation."!
Item was added:
+ ----- Method: TextMorph>>fixUponLoad:seg: (in category 'objects from disk') -----
+ fixUponLoad: aProject seg: anImageSegment
+ "We are in an old project that is being loaded from disk.
+ Fix up conventions that have changed."
+
+ | substituteFont |
+ substituteFont := aProject projectParameters at:
+ #substitutedFont ifAbsent: [#none].
+ (substituteFont ~~ #none and: [self textStyle fontArray
+ includes: substituteFont])
+ ifTrue: [ self fit ].
+
+ ^ super fixUponLoad: aProject seg: anImageSegment!
Item was added:
+ ----- Method: TextMorph>>followCurve (in category 'menu') -----
+ followCurve
+ self setContainer: (TextOnCurveContainer new baseline: 0; textDirection: 1).
+ self changed!
Item was added:
+ ----- Method: TextMorph>>font: (in category 'accessing') -----
+ font: aFont
+ | newTextStyle |
+ newTextStyle := aFont textStyle copy ifNil: [ TextStyle fontArray: { aFont } ].
+ textStyle := newTextStyle.
+ text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOf: aFont)).
+ paragraph ifNotNil: [paragraph textStyle: newTextStyle]!
Item was added:
+ ----- Method: TextMorph>>fontName:pointSize: (in category 'accessing') -----
+ fontName: fontName pointSize: fontSize
+ | newTextStyle |
+ newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy.
+ newTextStyle ifNil: [self error: 'font ', fontName, ' not found.'].
+
+ textStyle := newTextStyle.
+ text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfPointSize: fontSize)).
+ paragraph ifNotNil: [paragraph textStyle: newTextStyle]!
Item was added:
+ ----- Method: TextMorph>>fontName:size: (in category 'accessing') -----
+ fontName: fontName size: fontSize
+ | newTextStyle |
+ newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy.
+ textStyle := newTextStyle.
+ text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfSize: fontSize)).
+ paragraph ifNotNil: [paragraph textStyle: newTextStyle]!
Item was added:
+ ----- Method: TextMorph>>getAllButFirstCharacter (in category 'scripting access') -----
+ getAllButFirstCharacter
+ "Obtain all but the first character from the receiver; if that would be empty, return a black dot"
+
+ | aString |
+ ^ (aString := text string) size > 1 ifTrue: [aString copyFrom: 2 to: aString size] ifFalse: ['·']!
Item was added:
+ ----- Method: TextMorph>>getFirstCharacter (in category 'accessing') -----
+ getFirstCharacter
+ "obtain the first character from the receiver if it is empty, return a
+ black dot"
+ | aString |
+ ^ (aString := text string) isEmpty
+ ifTrue: ['·']
+ ifFalse: [aString first asString] !
Item was added:
+ ----- Method: TextMorph>>getLastCharacter (in category 'accessing') -----
+ getLastCharacter
+ "obtain the last character from the receiver if it is empty, return a black dot"
+
+ | aString |
+ ^ (aString := text string) size > 0 ifTrue: [aString last asString] ifFalse: ['·']!
Item was added:
+ ----- Method: TextMorph>>getMenu: (in category 'event handling') -----
+ getMenu: shiftKeyState
+ ^ (shiftKeyState not
+ or: [Preferences noviceMode])
+ ifTrue: [TextEditor yellowButtonMenu]
+ ifFalse: [TextEditor shiftedYellowButtonMenu]!
Item was added:
+ ----- Method: TextMorph>>goBehind (in category 'submorphs-add/remove') -----
+ goBehind
+ "We need to save the container, as it knows about fill and run-around"
+ | cont |
+ container ifNil: [^ super goBehind].
+ self releaseParagraph. "Cause recomposition"
+ cont := container. "Save the container"
+ super goBehind. "This will change owner, nilling the container"
+ container := cont. "Restore the container"
+ self changed!
Item was added:
+ ----- Method: TextMorph>>handleEdit: (in category 'editing') -----
+ handleEdit: editBlock
+ "Ensure that changed areas get suitably redrawn"
+ | result |
+ self selectionChanged. "Note old selection"
+ result := editBlock value.
+ self selectionChanged. "Note new selection"
+ self updateFromParagraph. "Propagate changes as necessary"
+ ^result!
Item was added:
+ ----- Method: TextMorph>>handleInteraction:fromEvent: (in category 'editing') -----
+ handleInteraction: interactionBlock fromEvent: evt
+ "Perform the changes in interactionBlock, noting any change in selection
+ and possibly a change in the size of the paragraph (ar 9/22/2001 - added for TextPrintIts)"
+ | oldEditor oldParagraph oldText |
+ oldEditor := editor.
+ oldParagraph := paragraph.
+ oldText := oldParagraph text copy.
+
+ self selectionChanged. "Note old selection"
+
+ interactionBlock value.
+
+ (oldParagraph == paragraph) ifTrue:[
+ "this will not work if the paragraph changed"
+ editor := oldEditor. "since it may have been changed while in block"
+ ].
+ self selectionChanged. "Note new selection"
+ (oldText = paragraph text and: [ oldText runs = paragraph text runs ])
+ ifFalse:[
+ self paragraph composeAll.
+ self updateFromParagraph ].
+ self setCompositionWindow.!
Item was added:
+ ----- Method: TextMorph>>handleKeystroke: (in category 'events-processing') -----
+ handleKeystroke: anEvent
+ "System level event handling."
+
+ | pasteUp |
+ anEvent wasHandled ifTrue:[^self].
+ (self handlesKeyboard: anEvent) ifFalse: [^ self].
+ anEvent wasHandled: true.
+ anEvent keyCharacter = Character tab ifTrue:
+ ["Allow passing through text morph inside pasteups"
+ (self wouldAcceptKeyboardFocusUponTab and:
+ [(pasteUp := self pasteUpMorphHandlingTabAmongFields) notNil])
+ ifTrue:[^ pasteUp tabHitWithEvent: anEvent]].
+ self keyStroke: anEvent!
Item was added:
+ ----- Method: TextMorph>>handleMouseMove: (in category 'events-processing') -----
+ handleMouseMove: anEvent
+ "Re-implemented to allow for mouse-up move events"
+ anEvent wasHandled ifTrue:[^self]. "not interested"
+ (anEvent hand hasSubmorphs) ifTrue:[^self].
+ anEvent wasHandled: true.
+ self mouseMove: anEvent.
+ (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
+ (self handlesMouseStillDown: anEvent) ifTrue:[
+ "Step at the new location"
+ self startStepping: #handleMouseStillDown:
+ at: Time millisecondClockValue
+ arguments: {anEvent copy resetHandlerFields}
+ stepTime: 1].
+ !
Item was added:
+ ----- Method: TextMorph>>handlesKeyboard: (in category 'event handling') -----
+ handlesKeyboard: evt
+ ^true!
Item was added:
+ ----- Method: TextMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ self isPartsDonor ifTrue: [^ false].
+ ^ self innerBounds containsPoint: evt cursorPoint!
Item was added:
+ ----- Method: TextMorph>>hasFocus (in category 'event handling') -----
+ hasFocus
+ ^editor notNil!
Item was added:
+ ----- Method: TextMorph>>hasTranslucentColor (in category 'accessing') -----
+ hasTranslucentColor
+ "Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+
+ backgroundColor ifNil: [^ true].
+ (backgroundColor isColor and: [backgroundColor isTranslucentColor]) ifTrue: [^ true].
+ (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [^ true].
+ ^ false
+ !
Item was added:
+ ----- Method: TextMorph>>hasUnacceptedEdits: (in category 'editing') -----
+ hasUnacceptedEdits: aBoolean
+ "Ignored here, but noted in TextMorphForEditView"
+ !
Item was added:
+ ----- Method: TextMorph>>holderForCharacters (in category 'menu') -----
+ holderForCharacters
+ "Hand the user a Holder that is populated with individual text morphs representing my characters"
+
+ | aHolder |
+ aHolder := ScriptingSystem prototypicalHolder.
+ aHolder setNameTo: 'H', self externalName.
+ text string do:
+ [:aChar |
+ aHolder addMorphBack: (TextMorph new contents: aChar asText)].
+ aHolder setProperty: #donorTextMorph toValue: self.
+ aHolder fullBounds.
+ aHolder openInHand!
Item was added:
+ ----- Method: TextMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ borderWidth := 0.
+ textStyle := TextStyle default copy.
+ wrapFlag := true.
+ !
Item was added:
+ ----- Method: TextMorph>>insertCharacters: (in category 'scripting access') -----
+ insertCharacters: aSource
+ "Insert the characters from the given source at my current cursor position"
+
+ | aLoc |
+ aLoc := self cursor max: 1.
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
+ self updateFromParagraph !
Item was added:
+ ----- Method: TextMorph>>insertContentsOf: (in category 'scripting access') -----
+ insertContentsOf: aPlayer
+ "Insert the characters from the given player at my current cursor position"
+
+ | aLoc |
+ aLoc := self cursor.
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aPlayer getStringContents displaying: true.
+ self updateFromParagraph !
Item was added:
+ ----- Method: TextMorph>>installEditorToReplace: (in category 'private') -----
+ installEditorToReplace: priorEditor
+ "Install an editor for my paragraph. This constitutes 'hasFocus'.
+ If priorEditor is not nil, then initialize the new editor from its state.
+ We may want to rework this so it actually uses the prior editor."
+
+ | stateArray |
+ priorEditor ifNotNil: [stateArray := priorEditor stateArray].
+ editor := self editorClass new morph: self.
+ editor changeParagraph: self paragraph.
+ priorEditor ifNotNil: [editor stateArrayPut: stateArray].
+ self selectionChanged.
+ ^ editor!
Item was added:
+ ----- Method: TextMorph>>isAutoFit (in category 'accessing') -----
+ isAutoFit
+ ^ self valueOfProperty: #autoFitContents ifAbsent: [true]
+ !
Item was added:
+ ----- Method: TextMorph>>isLinkedTo: (in category 'linked frames') -----
+ isLinkedTo: aMorph
+ self firstInChain withSuccessorsDo:
+ [:m | m == aMorph ifTrue: [^ true]].
+ ^ false!
Item was added:
+ ----- Method: TextMorph>>isTextMorph (in category 'classification') -----
+ isTextMorph
+ ^true!
Item was added:
+ ----- Method: TextMorph>>isWrapped (in category 'accessing') -----
+ isWrapped
+
+ ^wrapFlag!
Item was added:
+ ----- Method: TextMorph>>justified (in category 'alignment') -----
+ justified
+ self paragraph justified.
+ self updateFromParagraph!
Item was added:
+ ----- Method: TextMorph>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+ "Handle a keystroke event."
+
+ self resetBlinkCursor. "don't blink during type-in"
+ ToolSet
+ codeCompletionAround: [
+ evt keyValue = 13 ifTrue: [ "CR - check for special action"
+ self crAction ifNotNil: [ :action |
+ "Note: Code below assumes that this was some
+ input field reacting on CR. Break the keyboard
+ focus so that the receiver can be safely deleted."
+ evt hand newKeyboardFocus: nil.
+ ^action valueWithEnoughArguments: { evt } ] ].
+ self handleInteraction: [ self editor keyStroke: evt ] fromEvent: evt.
+ "self updateFromParagraph."
+ super keyStroke: evt "sends to keyStroke event handler, if any" ]
+ textMorph: self
+ keyStroke: evt!
Item was added:
+ ----- Method: TextMorph>>keyboardFocusChange: (in category 'event handling') -----
+ keyboardFocusChange: aBoolean
+ | w |
+ paragraph isNil ifFalse:[paragraph focused: aBoolean].
+ aBoolean ifTrue:["A hand is wanting to send us characters..."
+ self hasFocus ifFalse: [self editor "Forces install"].
+ Editor blinkingCursor ifTrue: [ self startBlinking ].
+ ] ifFalse:["A hand has clicked elsewhere..."
+ (w := self world) ifNotNil:[
+ w handsDo: [:h | h keyboardFocus == self ifTrue: [^self]].
+ "Release control unless some hand is still holding on"
+ self releaseEditor].
+ self stopBlinking.
+ ].
+ !
Item was added:
+ ----- Method: TextMorph>>lastCharacterIndex (in category 'linked frames') -----
+ lastCharacterIndex
+ ^ self paragraph lastCharacterIndex!
Item was added:
+ ----- Method: TextMorph>>leftFlush (in category 'alignment') -----
+ leftFlush
+ self paragraph leftFlush.
+ self updateFromParagraph!
Item was added:
+ ----- Method: TextMorph>>loadCachedState (in category 'caching') -----
+ loadCachedState
+ "Prepare for fast response -- next page of a book?"
+ self paragraph!
Item was added:
+ ----- Method: TextMorph>>margins (in category 'accessing') -----
+ margins
+
+ ^margins!
Item was added:
+ ----- Method: TextMorph>>margins: (in category 'accessing') -----
+ margins: newMargins
+ "newMargins can be a number, point or rectangle, as allowed by, eg, insetBy:."
+
+ margins := newMargins.
+ self composeToBounds!
Item was added:
+ ----- Method: TextMorph>>minimumExtent (in category 'geometry') -----
+ minimumExtent
+ | minExt |
+ textStyle ifNil: [^ 9 at 16].
+ borderWidth ifNil: [^ 9 at 16].
+ minExt := (9@(textStyle lineGrid+2)) + (borderWidth*2).
+ margins ifNil: [^ minExt].
+ ^ ((0 at 0 extent: minExt) expandBy: margins) extent!
Item was added:
+ ----- Method: TextMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "Make this TextMorph be the keyboard input focus, if it isn't
+ already, and repond to the text selection gesture."
+ evt yellowButtonPressed
+ ifTrue: ["First check for option (menu) click"
+ ^ self yellowButtonActivity: evt shiftPressed].
+ evt hand newKeyboardFocus: self.
+ self
+ handleInteraction: [editor mouseDown: evt]
+ fromEvent: evt.
+ !
Item was added:
+ ----- Method: TextMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ evt redButtonPressed ifFalse: [^ self enterClickableRegion: evt].
+ self handleInteraction: [self editor mouseMove: evt] fromEvent: evt!
Item was added:
+ ----- Method: TextMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+ self handleInteraction: [editor mouseUp: evt] fromEvent: evt!
Item was added:
+ ----- Method: TextMorph>>newContents: (in category 'accessing') -----
+ newContents: stringOrText
+ "Accept new text contents."
+ | newText embeddedMorphs oldSelection |
+ "If my text is all the same font, use the font for my new contents"
+ newText := stringOrText isString ifTrue: [ | textSize |
+ (text notNil
+ and: [ (textSize := text size) > 0
+ and: [ (text runLengthFor: 1) = textSize ]]) ifTrue: [ | attribs |
+ attribs := text attributesAt: 1 forStyle: textStyle.
+ Text string: stringOrText copy attributes: attribs.
+ ]
+ ifFalse: [ Text fromString: stringOrText copy ]
+ ]
+ ifFalse: [ stringOrText copy asText. "should be veryDeepCopy?" ].
+
+ (text = newText and: [text runs = newText runs]) ifTrue: [^ self]. "No substantive change"
+ text ifNotNil: [(embeddedMorphs := text embeddedMorphs)
+ ifNotNil:
+ [self removeAllMorphsIn: embeddedMorphs.
+ embeddedMorphs do: [:m | m delete]]].
+
+ oldSelection := editor ifNotNil: [:ed | ed selectionInterval].
+ text := newText.
+
+ "add all morphs off the visible region; they'll be moved into the right
+ place when they become visible. (this can make the scrollable area too
+ large, though)"
+ newText embeddedMorphs do:
+ [:m |
+ self addMorph: m.
+ m position: -1000 @ 0].
+ self releaseParagraph.
+ "update the paragraph cache"
+ self paragraph.
+ oldSelection ifNotNil: [:sel | self selectFrom: sel first to: sel last].
+ "re-instantiate to set bounds"
+ self world ifNotNil: [self world startSteppingSubmorphsOf: self]!
Item was added:
+ ----- Method: TextMorph>>occlusionsOnOff (in category 'containment') -----
+ occlusionsOnOff
+ "Establish a container for this text, with opposite occlusion avoidance status"
+ self setContainer:
+ (container
+ ifNil: [(TextContainer new for: self minWidth: textStyle lineGrid*2)
+ fillsOwner: false; avoidsOcclusions: true]
+ ifNotNil: [(container avoidsOcclusions and: [container fillsOwner not])
+ ifTrue: [nil "Return to simple rectangular bounds"]
+ ifFalse: [container avoidsOcclusions: container avoidsOcclusions not]])!
Item was added:
+ ----- Method: TextMorph>>onBlinkCursor (in category 'blinking') -----
+ onBlinkCursor
+ "Blink the cursor"
+ | para |
+ para := self paragraph ifNil:[^nil].
+ Time millisecondClockValue < self blinkStart ifTrue:[
+ "don't blink yet"
+ ^para showCaret: para focused.
+ ].
+ para showCaret: para showCaret not.
+ para caretRect ifNotNil: [ :r | self invalidRect: r].!
Item was added:
+ ----- Method: TextMorph>>ownerChanged (in category 'change reporting') -----
+ ownerChanged
+ | priorEditor |
+ super ownerChanged.
+ container ifNotNil:
+ [editor isNil
+ ifTrue:
+ [self releaseParagraph.
+ (container isKindOf: TextContainer) ifTrue:
+ ["May need to recompose due to changes in owner"
+ self installEditorToReplace: nil.
+ self releaseParagraph]]
+ ifFalse:
+ [priorEditor := editor.
+ self releaseParagraph.
+ self installEditorToReplace: priorEditor]]!
Item was added:
+ ----- Method: TextMorph>>paragraph (in category 'private') -----
+ paragraph
+ "Paragraph instantiation is lazy -- create it only when needed"
+ paragraph ifNotNil: [^ paragraph].
+
+ self setProperty: #CreatingParagraph toValue: true.
+
+ self setDefaultContentsIfNil.
+
+ "...Code here to recreate the paragraph..."
+ paragraph := (self paragraphClass new textOwner: self owner).
+ paragraph wantsColumnBreaks: successor notNil.
+ paragraph
+ compose: text
+ style: textStyle copy
+ from: self startingIndex
+ in: self container.
+ wrapFlag ifFalse:
+ ["Was given huge container at first... now adjust"
+ paragraph adjustRightX].
+ paragraph focused: (self currentHand keyboardFocus == self).
+ self fit.
+ self removeProperty: #CreatingParagraph.
+
+
+ ^ paragraph!
Item was added:
+ ----- Method: TextMorph>>paragraphClass (in category 'private') -----
+ paragraphClass
+ container ifNil: [^ NewParagraph].
+ ^ container paragraphClass!
Item was added:
+ ----- Method: TextMorph>>passKeyboardFocusTo: (in category 'editing') -----
+ passKeyboardFocusTo: otherMorph
+ | w |
+ self flag: #arNote. "Do we need this?!!"
+ (w := self world) isNil
+ ifFalse:
+ [w
+ handsDo: [:h | h keyboardFocus == self ifTrue: [h newKeyboardFocus: otherMorph]]]!
Item was added:
+ ----- Method: TextMorph>>predecessor (in category 'linked frames') -----
+ predecessor
+ ^ predecessor!
Item was added:
+ ----- Method: TextMorph>>predecessor:successor: (in category 'private') -----
+ predecessor: pred successor: succ
+ "Private -- for use only in morphic duplication"
+ predecessor := pred.
+ successor := succ.
+ !
Item was added:
+ ----- Method: TextMorph>>predecessorChanged (in category 'private') -----
+ predecessorChanged
+ | newStart oldStart |
+ (self hasProperty: #CreatingParagraph) ifTrue: [^self].
+ newStart := predecessor isNil
+ ifTrue: [1]
+ ifFalse: [predecessor lastCharacterIndex + 1].
+ (self paragraph adjustedFirstCharacterIndex ~= newStart
+ or: [newStart >= text size])
+ ifTrue:
+ [paragraph composeAllStartingAt: newStart.
+ self fit]
+ ifFalse:
+ ["If the offset to end of text has not changed, just slide"
+
+ oldStart := self firstCharacterIndex.
+ self withSuccessorsDo: [:m | m adjustLineIndicesBy: newStart - oldStart]]!
Item was added:
+ ----- Method: TextMorph>>preferredKeyboardPosition (in category 'editing') -----
+ preferredKeyboardPosition
+
+ | default rects |
+ default := (self bounds: self bounds in: World) topLeft.
+ paragraph ifNil: [^ default].
+ rects := paragraph selectionRects.
+ rects size = 0 ifTrue: [^ default].
+ ^ rects first topLeft.
+
+ "^ (self bounds: self bounds in: World) topLeft."
+ !
Item was added:
+ ----- Method: TextMorph>>privateMoveBy: (in category 'geometry') -----
+ privateMoveBy: delta
+ super privateMoveBy: delta.
+ editor
+ ifNil: [ paragraph ifNotNil: [paragraph moveBy: delta]]
+ ifNotNil: [
+ "When moving text with an active editor, save and restore all state."
+ paragraph moveBy: delta.
+ self installEditorToReplace: editor]!
Item was added:
+ ----- Method: TextMorph>>privateOwner: (in category 'private') -----
+ privateOwner: newOwner
+ "Nil the container when text gets extracted"
+ super privateOwner: newOwner.
+ container ifNotNil: [
+ newOwner ifNotNil: [
+ newOwner isWorldOrHandMorph ifTrue: [self setContainer: nil]]]!
Item was added:
+ ----- Method: TextMorph>>recognizerArena (in category 'containment') -----
+ recognizerArena
+ "Answer the rectangular area, in world coordinates, that the character recognizer should regard as its tablet"
+
+ | outer |
+ ^ (outer := self ownerThatIsA: PluggableTextMorph)
+ ifNotNil:
+ [outer boundsInWorld]
+ ifNil:
+ [self boundsInWorld]!
Item was added:
+ ----- Method: TextMorph>>recomposeChain (in category 'linked frames') -----
+ recomposeChain
+ "Recompose this textMorph and all that follow it."
+ self withSuccessorsDo:
+ [:m | m text: text textStyle: textStyle; "Propagate new style if any"
+ releaseParagraph; "Force recomposition"
+ fit "and propagate the change"]!
Item was added:
+ ----- Method: TextMorph>>releaseCachedState (in category 'caching') -----
+ releaseCachedState
+
+ super releaseCachedState.
+ self releaseParagraph; paragraph.
+ !
Item was added:
+ ----- Method: TextMorph>>releaseEditor (in category 'private') -----
+ releaseEditor
+ "Release the editor for my paragraph. This morph no longer 'hasFocus'."
+ editor ifNotNil:
+ [self selectionChanged.
+ self paragraph selectionStart: nil selectionStop: nil.
+ editor := nil].!
Item was added:
+ ----- Method: TextMorph>>releaseParagraph (in category 'private') -----
+ releaseParagraph
+
+ "a slight kludge so subclasses can have a bit more control over whether the paragraph really
+ gets released. important for GeeMail since the selection needs to be accessible even if the
+ hand is outside me"
+
+ self releaseParagraphReally.
+ !
Item was added:
+ ----- Method: TextMorph>>releaseParagraphReally (in category 'private') -----
+ releaseParagraphReally
+
+ "a slight kludge so subclasses can have a bit more control over whether the paragraph really
+ gets released. important for GeeMail since the selection needs to be accessible even if the
+ hand is outside me"
+
+ "Paragraph instantiation is lazy -- it will be created only when needed"
+ self releaseEditor.
+ paragraph ifNotNil:
+ [paragraph := nil].
+ container ifNotNil:
+ [container releaseCachedState]!
Item was added:
+ ----- Method: TextMorph>>removedMorph: (in category 'private') -----
+ removedMorph: aMorph
+ | range |
+ range := text find: (TextAnchor new anchoredMorph: aMorph).
+ range ifNotNil:
+ [self paragraph replaceFrom: range first to: range last
+ with: Text new displaying: false.
+ self fit].
+ aMorph textAnchorType: nil.
+ aMorph relativeTextAnchorPosition: nil.
+ super removedMorph: aMorph.!
Item was added:
+ ----- Method: TextMorph>>resetBlinkCursor (in category 'blinking') -----
+ resetBlinkCursor
+ "Reset the blinking cursor"
+ | para |
+ self blinkStart: Time millisecondClockValue + 500.
+ para := self paragraph ifNil:[^self].
+ para showCaret = para focused ifFalse:[
+ para caretRect ifNotNil: [ :r | self invalidRect: r].
+ para showCaret: para focused.
+ ].
+ !
Item was added:
+ ----- Method: TextMorph>>reverseCurveDirection (in category 'menu') -----
+ reverseCurveDirection
+ container textDirection: container textDirection negated.
+ self paragraph composeAll!
Item was added:
+ ----- Method: TextMorph>>rightFlush (in category 'alignment') -----
+ rightFlush
+ self paragraph rightFlush.
+ self updateFromParagraph!
Item was added:
+ ----- Method: TextMorph>>selectAll (in category 'accessing') -----
+ selectAll
+ self editor selectFrom: 1 to: text size!
Item was added:
+ ----- Method: TextMorph>>selectFrom:to: (in category 'accessing') -----
+ selectFrom: a to: b
+ self editor selectFrom: a to: b!
Item was added:
+ ----- Method: TextMorph>>selection (in category 'accessing') -----
+ selection
+ ^editor ifNotNil: [ editor selection ]!
Item was added:
+ ----- Method: TextMorph>>selectionChanged (in category 'private') -----
+ selectionChanged
+ "Invalidate all the selection rectangles.
+ Make sure that any drop shadow is accounted for too."
+ self paragraph selectionRects
+ do: [:r | self
+ invalidRect: (self expandFullBoundsForDropShadow: (r intersect: self fullBounds))]!
Item was added:
+ ----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') -----
+ setAllButFirstCharacter: source
+ "Set all but the first char of the receiver to the source"
+ | aChar chars |
+ aChar := source asCharacter.
+ (chars := self getCharacters) isEmpty
+ ifTrue: [self newContents: '·' , source asString]
+ ifFalse: [chars first = aChar
+ ifFalse: [""
+ self
+ newContents: (String
+ streamContents: [:aStream |
+ aStream nextPut: chars first.
+ aStream nextPutAll: source])]] !
Item was added:
+ ----- Method: TextMorph>>setCharacters: (in category 'accessing') -----
+ setCharacters: chars
+ "obtain a string value from the receiver"
+
+ (self getCharacters = chars) ifFalse:
+ [self newContents: chars]!
Item was added:
+ ----- Method: TextMorph>>setCompositionWindow (in category 'editing') -----
+ setCompositionWindow
+
+ | hand |
+ hand := self primaryHand.
+ hand ifNotNil: [hand compositionWindowManager keyboardFocusForAMorph: self].
+ !
Item was added:
+ ----- Method: TextMorph>>setContainer: (in category 'containment') -----
+ setContainer: newContainer
+ "Adopt (or abandon) container shape"
+ self changed.
+ container := newContainer.
+ self releaseParagraph!
Item was added:
+ ----- Method: TextMorph>>setCurveBaseline: (in category 'menu') -----
+ setCurveBaseline: evt
+ | handle origin |
+ origin := evt cursorPoint.
+ handle := HandleMorph new forEachPointDo:
+ [:newPoint | handle removeAllMorphs.
+ handle addMorph:
+ (PolygonMorph vertices: (Array with: origin with: newPoint)
+ color: Color black borderWidth: 1 borderColor: Color black).
+ container baseline: (newPoint - origin) y negated asInteger // 5.
+ self paragraph composeAll].
+ evt hand attachMorph: handle.
+ handle startStepping !
Item was added:
+ ----- Method: TextMorph>>setDefaultContentsIfNil (in category 'private') -----
+ setDefaultContentsIfNil
+ "Set the default contents"
+
+ | toUse |
+ text ifNil:
+ [toUse := self valueOfProperty: #defaultContents.
+ toUse ifNil: [toUse :='abc' asText "allBold"]. "try it plain for a while"
+ text := toUse]!
Item was added:
+ ----- Method: TextMorph>>setFirstCharacter: (in category 'accessing') -----
+ setFirstCharacter: source
+ "Set the first character of the receiver as indicated"
+ | aChar chars |
+ aChar := source asCharacter.
+ (chars := self getCharacters) isEmpty
+ ifTrue: [self
+ newContents: (String with: aChar)]
+ ifFalse: [chars first = aChar
+ ifFalse: [self
+ newContents: (String
+ streamContents: [:aStream |
+ aStream nextPut: aChar.
+ aStream
+ nextPutAll: (chars copyFrom: 2 to: chars size)])]] !
Item was added:
+ ----- Method: TextMorph>>setLastCharacter: (in category 'accessing') -----
+ setLastCharacter: source
+ "Set the last character of the receiver as indicated"
+
+ | aChar chars |
+ aChar := source asCharacter.
+ (chars := self getCharacters) size > 0
+ ifFalse:
+ [self newContents: (String with: aChar)]
+ ifTrue:
+ [(chars last = aChar) ifFalse:
+ [self newContents: (String streamContents:
+ [:aStream |
+ aStream nextPutAll: (chars copyFrom: 1 to: (chars size - 1)).
+ aStream nextPut: aChar])]]!
Item was added:
+ ----- Method: TextMorph>>setPredecessor: (in category 'private') -----
+ setPredecessor: newPredecessor
+ predecessor := newPredecessor!
Item was added:
+ ----- Method: TextMorph>>setSuccessor: (in category 'private') -----
+ setSuccessor: newSuccessor
+
+ successor := newSuccessor.
+ paragraph ifNotNil: [paragraph wantsColumnBreaks: successor notNil].
+ !
Item was added:
+ ----- Method: TextMorph>>setTextStyle: (in category 'initialization') -----
+ setTextStyle: aTextStyle
+
+ textStyle := aTextStyle.
+ self releaseCachedState; changed!
Item was added:
+ ----- Method: TextMorph>>startBlinking (in category 'blinking') -----
+ startBlinking
+ self startStepping: #onBlinkCursor
+ at: Time millisecondClockValue
+ arguments: nil stepTime: 500.
+ self resetBlinkCursor.
+ !
Item was added:
+ ----- Method: TextMorph>>startingIndex (in category 'linked frames') -----
+ startingIndex
+ predecessor isNil
+ ifTrue: [^ 1].
+ ^ predecessor lastCharacterIndex + 1 !
Item was added:
+ ----- Method: TextMorph>>stopBlinking (in category 'blinking') -----
+ stopBlinking
+ self stopSteppingSelector: #onBlinkCursor.
+ !
Item was added:
+ ----- Method: TextMorph>>string:fontName:size: (in category 'initialization') -----
+ string: aString fontName: aName size: aSize
+
+ self string: aString fontName: aName size: aSize wrap: true!
Item was added:
+ ----- Method: TextMorph>>string:fontName:size:wrap: (in category 'initialization') -----
+ string: aString fontName: aName size: aSize wrap: shouldWrap
+
+ shouldWrap
+ ifTrue: [self contentsWrapped: aString]
+ ifFalse: [self contents: aString].
+ self fontName: aName size: aSize!
Item was added:
+ ----- Method: TextMorph>>successor (in category 'linked frames') -----
+ successor
+ ^ successor!
Item was added:
+ ----- Method: TextMorph>>text (in category 'accessing') -----
+ text
+ ^ text!
Item was added:
+ ----- Method: TextMorph>>text:textStyle: (in category 'private') -----
+ text: t textStyle: s
+ "Private -- for use only in morphic duplication"
+ text := t.
+ textStyle := s.
+ paragraph ifNotNil: [paragraph textStyle: s]!
Item was added:
+ ----- Method: TextMorph>>text:textStyle:wrap:color:predecessor:successor: (in category 'private') -----
+ text: t textStyle: s wrap: wrap color: c
+ predecessor: pred successor: succ
+ "Private -- for use only in morphic duplication"
+ text := t.
+ textStyle := s.
+ wrapFlag := wrap.
+ color := c.
+ paragraph := editor := container := nil.
+ self predecessor: pred successor: succ!
Item was added:
+ ----- Method: TextMorph>>textAlignment (in category 'accessing') -----
+ textAlignment
+ "Answer 1..4, representing #leftFlush, #rightFlush, #centered, or #justified"
+ ^self editor textAlignment!
Item was added:
+ ----- Method: TextMorph>>textAlignmentSymbol (in category 'accessing') -----
+ textAlignmentSymbol
+ "Answer one of #leftFlush, #rightFlush, #centered, or #justified"
+ ^self editor textAlignmentSymbol!
Item was added:
+ ----- Method: TextMorph>>textBounds (in category 'geometry') -----
+ textBounds
+ ^ bounds!
Item was added:
+ ----- Method: TextMorph>>textColor (in category 'accessing') -----
+ textColor
+
+ ^ color!
Item was added:
+ ----- Method: TextMorph>>textColor: (in category 'accessing') -----
+ textColor: aColor
+
+ color = aColor ifTrue: [^ self].
+ color := aColor.
+ self changed.
+ !
Item was added:
+ ----- Method: TextMorph>>textStyle (in category 'accessing') -----
+ textStyle
+ ^textStyle!
Item was added:
+ ----- Method: TextMorph>>updateFromParagraph (in category 'private') -----
+ updateFromParagraph
+ "A change has taken place in my paragraph, as a result of editing and I must be updated. If a line break causes recomposition of the current paragraph, or it the selection has entered a different paragraph, then the current editor will be released, and must be reinstalled with the resulting new paragraph, while retaining any editor state, such as selection, undo state, and current typing emphasis."
+
+ | newStyle sel oldLast oldEditor back |
+ paragraph ifNil: [^self].
+ wrapFlag ifNil: [wrapFlag := true].
+ editor ifNotNil:
+ [oldEditor := editor.
+ sel := editor selectionInterval.
+ editor storeSelectionInParagraph].
+ text := paragraph text.
+ paragraph textStyle = textStyle
+ ifTrue: [self fit]
+ ifFalse:
+ ["Broadcast style changes to all morphs"
+
+ newStyle := paragraph textStyle.
+ (self firstInChain text: text textStyle: newStyle) recomposeChain.
+ editor ifNotNil: [self installEditorToReplace: editor]].
+ super layoutChanged.
+ sel ifNil: [^self].
+
+ "If selection is in top line, then recompose predecessor for possible ripple-back"
+ predecessor ifNotNil:
+ [sel first <= (self paragraph lines first last + 1)
+ ifTrue:
+ [oldLast := predecessor lastCharacterIndex.
+ predecessor paragraph
+ recomposeFrom: oldLast
+ to: text size
+ delta: 0.
+ oldLast = predecessor lastCharacterIndex
+ ifFalse:
+ [predecessor changed. "really only last line"
+ self predecessorChanged]]].
+ ((back := predecessor notNil
+ and: [sel first <= self paragraph firstCharacterIndex]) or:
+ [successor notNil
+ and: [sel first > (self paragraph lastCharacterIndex + 1)]])
+ ifTrue:
+ ["The selection is no longer inside this paragraph.
+ Pass focus to the paragraph that should be in control."
+
+ back ifTrue: [predecessor recomposeChain] ifFalse: [self recomposeChain].
+ self firstInChain withSuccessorsDo:
+ [:m |
+ (sel first between: m firstCharacterIndex and: m lastCharacterIndex + 1)
+ ifTrue:
+ [m installEditorToReplace: oldEditor.
+ ^self passKeyboardFocusTo: m]].
+ self error: 'Inconsistency in text editor' "Must be somewhere in the successor chain"].
+ editor ifNil:
+ ["Reinstate selection after, eg, style change"
+
+ self installEditorToReplace: oldEditor].
+ "self setCompositionWindow."
+ !
Item was added:
+ ----- Method: TextMorph>>userString (in category 'accessing') -----
+ userString
+ "Do I have a text string to be searched on?"
+
+ ^ text string!
Item was added:
+ ----- Method: TextMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If target and arguments fields were weakly copied, fix them here. If
+ they were in the tree being copied, fix them up, otherwise point to the
+ originals!!"
+
+ super veryDeepFixupWith: deepCopier.
+ "It makes no sense to share pointers to an existing predecessor and successor"
+ predecessor := deepCopier references at: predecessor ifAbsent: [nil].
+ successor := deepCopier references at: successor ifAbsent: [nil]!
Item was added:
+ ----- Method: TextMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared.
+ Warning!!!! Every instance variable defined in this class must be handled.
+ We must also implement veryDeepFixupWith:. See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ textStyle := textStyle veryDeepCopyWith: deepCopier.
+ text := text veryDeepCopyWith: deepCopier.
+ wrapFlag := wrapFlag veryDeepCopyWith: deepCopier.
+ paragraph := paragraph veryDeepCopyWith: deepCopier.
+ editor := editor veryDeepCopyWith: deepCopier.
+ container := container veryDeepCopyWith: deepCopier.
+ predecessor := predecessor.
+ successor := successor.
+ backgroundColor := backgroundColor veryDeepCopyWith: deepCopier.
+ margins := margins veryDeepCopyWith: deepCopier.
+ editHistory := editHistory veryDeepCopyWith: deepCopier.
+ !
Item was added:
+ ----- Method: TextMorph>>withSuccessorsDo: (in category 'linked frames') -----
+ withSuccessorsDo: aBlock
+ "Evaluate aBlock for each morph in my successor chain"
+
+ | each |
+ each := self.
+ [each isNil] whileFalse:
+ [aBlock value: each.
+ each := each successor]!
Item was added:
+ ----- Method: TextMorph>>wouldAcceptKeyboardFocusUponTab (in category 'event handling') -----
+ wouldAcceptKeyboardFocusUponTab
+ "Answer whether the receiver might accept keyboard focus if
+ tab were hit in some container playfield"
+ ^ self inPartsBin not!
Item was added:
+ ----- Method: TextMorph>>wrapFlag: (in category 'accessing') -----
+ wrapFlag: aBoolean
+ "Whether contained text will adjust its bounds as I change shape:
+ | wrapFlag | TextMorph grows | TextMorph shrinks |
+ | true | wrapped lines fill new space | long lines wrap to fit |
+ | false | wrapped lines stay same | long lines are cut off |"
+
+ aBoolean == wrapFlag ifTrue: [^ self].
+ wrapFlag := aBoolean.
+ self composeToBounds!
Item was added:
+ ----- Method: TextMorph>>wrapOnOff (in category 'menu') -----
+ wrapOnOff
+ self wrapFlag: wrapFlag not!
Item was added:
+ ----- Method: TextMorph>>wrapString (in category 'menu') -----
+ wrapString
+ "Answer the string to put in a menu that will invite the user to
+ switch autoFit mode"
+ ^ (wrapFlag
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ , 'text wrap to bounds' translated!
Item was added:
+ ----- Method: TextMorph>>xeqLinkText:withParameter: (in category 'editing') -----
+ xeqLinkText: sourceString withParameter: param
+ self confirm: 'xeqLinkText:
+ ' asText allBold , sourceString asText!
Item was added:
+ ----- Method: TextMorph>>yellowButtonActivity: (in category 'event handling') -----
+ yellowButtonActivity: shiftKeyState
+ "Invoke the text-editing menu"
+ | menu |
+ (menu := self getMenu: shiftKeyState)
+ ifNotNil: [""
+ menu setInvokingView: self editor.
+ menu invokeModal. self changed]!
Item was added:
+ CommandHistory subclass: #TextMorphCommandHistory
+ instanceVariableNames: 'textMorph'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
Item was added:
+ ----- Method: TextMorphCommandHistory>>redo (in category 'command exec') -----
+ redo
+ ^super redoNextCommand
+ !
Item was added:
+ ----- Method: TextMorphCommandHistory>>rememberCommand: (in category 'command exec') -----
+ rememberCommand: aCommand
+ "Make the supplied command be the 'LastCommand', and mark it 'done'"
+
+ "Before adding the new command, remove any commands after the last #done
+ command, and make that last #done command be lastCommand."
+ self removeUndoneCommands.
+ aCommand phase: #done.
+
+ "If we are building a compound command, just add the new command to that"
+ history addLast: aCommand.
+ lastCommand := aCommand.
+ "Debug dShow: ('Remember: ', commandToUse asString)."
+
+ !
Item was added:
+ ----- Method: TextMorphCommandHistory>>removeUndoneCommands (in category 'command exec') -----
+ removeUndoneCommands
+ "Remove all of the commands at the end of history until the first one that is not marked #undone"
+
+ history reversed do: [ :command |
+ (command phase == #done) ifTrue:[
+ lastCommand := command.
+ ^self
+ ]ifFalse:[
+ history remove: command.
+ ].
+ ].
+
+ "If there were no #done commands on the stack, then get rid of lastCommand"
+ lastCommand := nil.
+ !
Item was added:
+ ----- Method: TextMorphCommandHistory>>undo (in category 'command exec') -----
+ undo
+ ^super undoLastCommand
+
+ !
Item was added:
+ TextEditor subclass: #TextMorphEditor
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !TextMorphEditor commentStamp: 'dtl 1/21/2012 18:02' prior: 0!
+ This is a stub class to replace the original implementation of a ParagraphEditor for TextMorphs, which has since been replaced by TextEditor. This implementation is retained for the benefit of external packages such as Connectors and FreeType that may have dependencies on TextMorphEditor.
+
+ The comment below is from the class comment of the original TextMorphEditor.
+ -----
+ In the past, BookMorphs had the ability to have each page be on the server as a .sp SqueakPage file. The index of the book was a .bo file. In text, Cmd-6 had a LinkTo option that linked to a page by its name, or created a new page of that name. It assumed the book was on a server with a file per page. Ted removed that code, and kept a copy on his disk in 'TME-ChngEmphasis.st for .bo .sp'!
Item was added:
+ TextMorph subclass: #TextMorphForEditView
+ instanceVariableNames: 'editView acceptOnCR'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
Item was added:
+ ----- Method: TextMorphForEditView class>>includeInNewMorphMenu (in category 'new-morph participation') -----
+ includeInNewMorphMenu
+ "Not to be instantiated from the menu"
+ ^ false!
Item was added:
+ ----- Method: TextMorphForEditView>>acceptContents (in category 'editing') -----
+ acceptContents
+ "The message is sent when the user hits enter or Cmd-S.
+ Accept the current contents and end editing."
+ self updateFromParagraph.
+ editView accept.!
Item was added:
+ ----- Method: TextMorphForEditView>>acceptOnCR (in category 'editing') -----
+ acceptOnCR
+ "Answer whether the receiver wants to accept when the Return key is hit"
+
+ ^ acceptOnCR == true!
Item was added:
+ ----- Method: TextMorphForEditView>>acceptOnCR: (in category 'accept/cancel') -----
+ acceptOnCR: trueOrFalse
+ acceptOnCR := trueOrFalse!
Item was added:
+ ----- Method: TextMorphForEditView>>autoScrollView: (in category 'event handling') -----
+ autoScrollView: evt
+ "This is kind of a hack because the PluggableTextMorph expects me to first expand the selection before auto scrolling will work."
+ | localEvt |
+ localEvt := evt transformedBy: (self transformedFrom: editView).
+ super mouseMove: localEvt.
+ editView scrollSelectionIntoView: localEvt.!
Item was added:
+ ----- Method: TextMorphForEditView>>cancelEdits (in category 'editing') -----
+ cancelEdits
+ "The message is sent when the user hits enter or Cmd-L.
+ Cancel the current contents and end editing."
+ self releaseParagraph.
+ editView cancel!
Item was added:
+ ----- Method: TextMorphForEditView>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ acceptOnCR ifNil: [acceptOnCR := false].
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: TextMorphForEditView>>drawNullTextOn: (in category 'drawing') -----
+ drawNullTextOn: aCanvas
+ "Just run the normal code to show selection in a window"
+ aCanvas paragraph: self paragraph bounds: bounds color: color
+ !
Item was added:
+ ----- Method: TextMorphForEditView>>editView (in category 'edit view') -----
+ editView
+ ^ editView!
Item was added:
+ ----- Method: TextMorphForEditView>>flash (in category 'macpal') -----
+ flash
+ ^ editView flash!
Item was added:
+ ----- Method: TextMorphForEditView>>handleInteraction:fromEvent: (in category 'editing') -----
+ handleInteraction: interActionBlock fromEvent: evt
+ "Overridden to pass along a model to the editor for, eg, link resolution, doits, etc"
+
+ self editor model: editView model. "For evaluateSelection, etc"
+ ^ super handleInteraction: interActionBlock fromEvent: evt!
Item was added:
+ ----- Method: TextMorphForEditView>>hasUnacceptedEdits: (in category 'editing') -----
+ hasUnacceptedEdits: aBoolean
+ "Set the hasUnacceptedEdits flag in my view."
+
+ editView hasUnacceptedEdits: aBoolean!
Item was added:
+ ----- Method: TextMorphForEditView>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ acceptOnCR := false!
Item was added:
+ ----- Method: TextMorphForEditView>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+ | view |
+ editView deleteBalloon.
+ (editView scrollByKeyboard: evt) ifTrue: [^self].
+ self editor model: editView model. "For evaluateSelection"
+ view := editView. "Copy into temp for case of a self-mutating doit"
+ (acceptOnCR and: [evt keyCharacter = Character cr])
+ ifTrue: [^ self editor accept].
+ super keyStroke: evt.
+ view scrollSelectionIntoView.
+
+ "Make a cheap check and guess editing. (Alternative would be to copy the old contents and then compare them against the new ones. Maybe add a better hook in the TextEditor."
+ (evt keyCharacter isAlphaNumeric or: [evt keyCharacter isSeparator])
+ ifTrue: [view textEdited: self contents].!
Item was added:
+ ----- Method: TextMorphForEditView>>keyboardFocusChange: (in category 'event handling') -----
+ keyboardFocusChange: aBoolean
+ "rr 3/21/2004 22:55 : removed the #ifFalse: branch,
+ which was responsible of the deselection of text when the
+ paragraph lost focus. This way selection works in a more standard
+ way, and this permits the menu keyboard control to be really effective"
+ paragraph isNil ifFalse:[paragraph focused: aBoolean].
+ aBoolean
+ ifTrue: [
+ "A hand is wanting to send us characters..."
+ self hasFocus ifFalse: [self editor "Forces install"].
+ Editor blinkingCursor ifTrue: [self startBlinking]]
+ ifFalse:[
+ self stopBlinking].
+ self changed.
+
+ "Tell my edit-view about this because I am his delegate."
+ self editView keyboardFocusChange: aBoolean.
+ !
Item was added:
+ ----- Method: TextMorphForEditView>>mouseDown: (in category 'event handling') -----
+ mouseDown: event
+
+ event yellowButtonPressed ifTrue: [
+ (self editor yellowButtonDown: event) ifTrue:[^self].
+ ^ editView yellowButtonActivity: event shiftPressed].
+ ^ super mouseDown: event
+ !
Item was added:
+ ----- Method: TextMorphForEditView>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ | editEvt |
+ super mouseMove: evt.
+ evt redButtonPressed ifFalse: [^ self].
+ editEvt := evt transformedBy: (self transformedFrom: editView) inverseTransformation.
+ (editEvt position y between: editView top and: editView bottom) ifFalse:[
+ "Start auto-scrolling"
+ self startStepping: #autoScrollView:
+ at: Time millisecondClockValue
+ arguments: (Array with: editEvt)
+ stepTime: 100. "fast enough"
+ ] ifTrue:[
+ self stopSteppingSelector: #autoScrollView:.
+ ].!
Item was added:
+ ----- Method: TextMorphForEditView>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+ super mouseUp: evt.
+ self stopSteppingSelector: #autoScrollView:.
+ editView scrollSelectionIntoView: evt.
+
+ self setCompositionWindow.
+ !
Item was added:
+ ----- Method: TextMorphForEditView>>preferredKeyboardPosition (in category 'event handling') -----
+ preferredKeyboardPosition
+
+ | pos |
+ pos := super preferredKeyboardPosition.
+ ^ pos + (self bounds: self bounds in: World) topLeft.
+ !
Item was added:
+ ----- Method: TextMorphForEditView>>selectAll (in category 'miscellaneous') -----
+ selectAll
+ "Tell my editor to select all the text"
+
+ self editor selectAll!
Item was added:
+ ----- Method: TextMorphForEditView>>setEditView: (in category 'edit view') -----
+ setEditView: editPane
+ editView := editPane!
Item was added:
+ ----- Method: TextMorphForEditView>>tempCommand (in category 'debug and other') -----
+ tempCommand
+ "Smalltalk browseAllImplementorsOf: #tempCommand"
+ "Place your definition for tempCommand for this class here"!
Item was added:
+ ----- Method: TextMorphForEditView>>updateFromParagraph (in category 'private') -----
+ updateFromParagraph
+ super updateFromParagraph.
+ editView setScrollDeltas.!
Item was added:
+ ----- Method: TextMorphForEditView>>wouldAcceptKeyboardFocusUponTab (in category 'event handling') -----
+ wouldAcceptKeyboardFocusUponTab
+ "Answer whether the receiver would be a happy inheritor of keyboard focus if tab were hit in an enclosing playfield under propitious circumstances. Does not make sense for this kind of morph, which is encased in a window"
+
+ ^ false!
Item was added:
+ ----- Method: TextStyle class>>emphasisMenuForFont:target:selector:highlight: (in category '*Morphic-user interface') -----
+ emphasisMenuForFont: font target: target selector: selector highlight: currentEmphasis
+ "Offer a font emphasis menu for the given style. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font.
+ Answer nil if no derivatives exist.
+ "
+
+ | aMenu derivs |
+ derivs := font derivativeFonts.
+ derivs isEmpty ifTrue: [ ^nil ].
+ aMenu := MenuMorph entitled: 'emphasis' translated.
+ derivs := derivs asOrderedCollection.
+ derivs addFirst: font.
+ derivs do: [ :df |
+ aMenu
+ add: df emphasisString
+ target: target
+ selector: selector
+ argument: df.
+ aMenu lastItem font: df.
+ df emphasis == currentEmphasis ifTrue: [aMenu lastItem color: Color blue darker]].
+ ^ aMenu!
Item was added:
+ ----- Method: TextStyle class>>fontMenuForStyle:target:selector: (in category '*Morphic-user interface') -----
+ fontMenuForStyle: styleName target: target selector: selector
+ ^self fontMenuForStyle: styleName target: target selector: selector highlight: nil!
Item was added:
+ ----- Method: TextStyle class>>fontMenuForStyle:target:selector:highlight: (in category '*Morphic-user interface') -----
+ fontMenuForStyle: styleName target: target selector: selector highlight: currentFont
+ "Offer a font menu for the given style. If one is selected, pass
+ that font to target with a
+ call to selector. The fonts will be displayed in that font."
+ | aMenu |
+ aMenu := MenuMorph entitled: styleName.
+ (TextStyle named: styleName)
+ ifNotNil: [:s | s isTTCStyle
+ ifTrue: [aMenu
+ add: 'New Size'
+ target: self
+ selector: #chooseTTCFontSize:
+ argument: {styleName. target. selector}]].
+ (self pointSizesFor: styleName)
+ do: [:pointSize |
+ | font subMenu displayFont |
+ font := (self named: styleName)
+ fontOfPointSize: pointSize.
+ subMenu := self
+ emphasisMenuForFont: font
+ target: target
+ selector: selector
+ highlight: (currentFont
+ ifNotNil: [:cf | (cf familyName = styleName
+ and: [cf pointSize = font pointSize])
+ ifTrue: [currentFont emphasis]]).
+ subMenu
+ ifNil: [aMenu
+ add: pointSize asString , ' Point'
+ target: target
+ selector: selector
+ argument: font]
+ ifNotNil: [aMenu add: pointSize asString , ' Point' subMenu: subMenu].
+ displayFont := font.
+ (font isSymbolFont or:[(font hasDistinctGlyphsForAll: pointSize asString , ' Point') not])
+ ifTrue:[
+ "don't use a symbol font to display its own name!!!!"
+ displayFont := self default fontOfPointSize: pointSize].
+ aMenu lastItem font: displayFont.
+ currentFont
+ ifNotNil: [:cf | (cf familyName = styleName
+ and: [cf pointSize = font pointSize])
+ ifTrue: [aMenu lastItem color: Color blue darker]]].
+ ^ aMenu!
Item was added:
+ ----- Method: TextStyle class>>fontSizeSummary (in category '*Morphic-user interface') -----
+ fontSizeSummary
+ "Open a text window with a simple summary of the available sizes in each of the fonts in the system."
+
+ "TextStyle fontSizeSummary"
+ | aString aList |
+ aList := self knownTextStyles.
+ aString := String streamContents:
+ [:aStream |
+ aList do: [:aStyleName |
+ aStream nextPutAll:
+ aStyleName, ' ',
+ (self fontPointSizesFor: aStyleName) asArray storeString.
+ aStream cr]].
+ (StringHolder new contents: aString)
+ openLabel: 'Font styles and sizes' translated!
Item was added:
+ ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector: (in category '*Morphic-user interface') -----
+ promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector
+ self promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: nil!
Item was added:
+ ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector:highlight: (in category '*Morphic-user interface') -----
+ promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: currentFont
+ "Morphic Only!! prompt for a font and if one is provided, send it to aTarget using a
+ message with selector aSelector."
+ "TextStyle promptForFont: 'Choose system font:' andSendTo: Preferences withSelector:
+ #setSystemFontTo: "
+ "Derived from a method written by Robin Gibson"
+ | menu currentTextStyle |
+ currentTextStyle := currentFont
+ ifNotNil: [currentFont textStyleName].
+ menu := MenuMorph entitled: aPrompt.
+ self actualTextStyles keysSortedSafely
+ do: [:styleName | | subMenu |
+ subMenu := self
+ fontMenuForStyle: styleName
+ target: aTarget
+ selector: aSelector
+ highlight: currentFont.
+ menu add: styleName subMenu: subMenu.
+ menu lastItem
+ font: ((self named: styleName)
+ fontOfSize: 18).
+ styleName = currentTextStyle
+ ifTrue: [menu lastItem color: Color blue darker]].
+ menu popUpInWorld: self currentWorld!
Item was added:
+ ----- Method: TextURL>>actOnClickFor: (in category '*Morphic') -----
+ actOnClickFor: anObject
+ "Do what you can with this URL. Later a web browser."
+
+ | response m |
+
+ (url beginsWith: 'sqPr://') ifTrue: [
+ ProjectLoading thumbnailFromUrl: (url copyFrom: 8 to: url size).
+ ^self "should not get here, but what the heck"
+ ].
+ "if it's a web browser, tell it to jump"
+ anObject isWebBrowser
+ ifTrue: [anObject jumpToUrl: url. ^ true]
+ ifFalse: [((anObject respondsTo: #model) and: [anObject model isWebBrowser])
+ ifTrue: [anObject model jumpToUrl: url. ^ true]].
+
+ "if it's a morph, see if it is contained in a web browser"
+ (anObject isKindOf: Morph) ifTrue: [
+ m := anObject.
+ [ m ~= nil ] whileTrue: [
+ (m isWebBrowser) ifTrue: [
+ m jumpToUrl: url.
+ ^true ].
+ (m hasProperty: #webBrowserView) ifTrue: [
+ m model jumpToUrl: url.
+ ^true ].
+ m := m owner. ]
+ ].
+
+ "no browser in sight. ask if we should start a new browser"
+ ((self confirm: 'open a browser to view this URL?' translated) and: [WebBrowser default notNil]) ifTrue: [
+ WebBrowser default openOnUrl: url.
+ ^ true ].
+
+ "couldn't display in a browser. Offer to put up just the source"
+
+ response := (UIManager default
+ chooseFrom: (Array with: 'View web page as source' translated
+ with: 'Cancel' translated)
+ title: 'Couldn''t find a web browser. View\page as source?' withCRs translated).
+ response = 1 ifTrue: [HTTPSocket httpShowPage: url].
+ ^ true!
Item was added:
+ Object subclass: #TheWorldMainDockingBar
+ instanceVariableNames: ''
+ classVariableNames: 'Instance TS'
+ poolDictionaries: ''
+ category: 'Morphic-Kernel'!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>cleanUp (in category 'initialize-release') -----
+ cleanUp
+ self updateInstances.!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>disableMenuPreference: (in category 'preferences') -----
+ disableMenuPreference: aPreferenceSymbol
+
+ self setMenuPreference: aPreferenceSymbol to: false.!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>enableMenuPreference: (in category 'preferences') -----
+ enableMenuPreference: aPreferenceSymbol
+
+ self setMenuPreference: aPreferenceSymbol to: true.!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>getMenuPreference: (in category 'preferences') -----
+ getMenuPreference: aPreferenceSymbol
+
+ ^ self getMenuPreference: aPreferenceSymbol ifAbsent: [true]!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>getMenuPreference:ifAbsent: (in category 'preferences') -----
+ getMenuPreference: aPreferenceSymbol ifAbsent: aBlock
+
+ | project |
+ ^ (project := Project current) isMorphic
+ ifTrue: [project projectPreferenceFlagDictionary at: aPreferenceSymbol ifAbsent: aBlock]
+ ifFalse: aBlock
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>initialize (in category 'class initialization') -----
+ initialize
+ "self initialize"
+
+ Locale addLocalChangedListener: self.
+ self updateInstances.!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>instance (in category 'access') -----
+ instance
+ "Answer the receiver's instance"
+ ^ Instance ifNil: [ Instance := self new ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>instance: (in category 'access') -----
+ instance: aTheWorldMainDockingBar
+ Instance := aTheWorldMainDockingBar.
+ self updateInstances!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>localeChanged (in category 'events') -----
+ localeChanged
+ self updateInstances!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>setMenuPreference:to: (in category 'preferences') -----
+ setMenuPreference: aPreferenceSymbol to: aBoolean
+ | project |
+ (project := Project current) isMorphic ifTrue: [
+ project projectPreferenceFlagDictionary at: aPreferenceSymbol put: aBoolean.
+ (aBoolean ~= (Preferences perform: aPreferenceSymbol))
+ ifTrue: [Preferences setPreference: aPreferenceSymbol toValue: aBoolean]].
+ self updateInstances.!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>setTimeStamp (in category 'timestamping') -----
+ setTimeStamp
+ "Change the receiver's timeStamp"
+ TS := UUID new!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showAppsMenuInWorldMainDockingBar (in category 'preferences') -----
+ showAppsMenuInWorldMainDockingBar
+
+ <preference: 'Show ''Apps'' menu in world main docking bar'
+ category: 'docking bars'
+ description: 'Whether world''s main docking bar should show the ''Apps'' menu.'
+ type: #Boolean>
+ ^ self getMenuPreference: #showAppsMenuInWorldMainDockingBar ifAbsent: [true]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showAppsMenuInWorldMainDockingBar: (in category 'preferences') -----
+ showAppsMenuInWorldMainDockingBar: aBoolean
+
+ self
+ setMenuPreference: #showAppsMenuInWorldMainDockingBar
+ to: aBoolean.
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showExtrasMenuInWorldMainDockingBar (in category 'preferences') -----
+ showExtrasMenuInWorldMainDockingBar
+
+ <preference: 'Show ''Extras'' menu in world main docking bar'
+ category: 'docking bars'
+ description: 'Whether world''s main docking bar should show the ''Extras'' menu.'
+ type: #Boolean>
+ ^ self getMenuPreference: #showExtrasMenuInWorldMainDockingBar ifAbsent: [true]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showExtrasMenuInWorldMainDockingBar: (in category 'preferences') -----
+ showExtrasMenuInWorldMainDockingBar: aBoolean
+
+ self
+ setMenuPreference: #showExtrasMenuInWorldMainDockingBar
+ to: aBoolean.
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showHelpMenuInWorldMainDockingBar (in category 'preferences') -----
+ showHelpMenuInWorldMainDockingBar
+
+ <preference: 'Show ''Help'' menu in world main docking bar'
+ category: 'docking bars'
+ description: 'Whether world''s main docking bar should show the ''Help'' menu.'
+ type: #Boolean>
+ ^ self getMenuPreference: #showHelpMenuInWorldMainDockingBar ifAbsent: [true]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showHelpMenuInWorldMainDockingBar: (in category 'preferences') -----
+ showHelpMenuInWorldMainDockingBar: aBoolean
+
+ self
+ setMenuPreference: #showHelpMenuInWorldMainDockingBar
+ to: aBoolean.
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showMainMenuInWorldMainDockingBar (in category 'preferences') -----
+ showMainMenuInWorldMainDockingBar
+
+ <preference: 'Show ''Main'' menu in world main docking bar'
+ category: 'docking bars'
+ description: 'Whether world''s main docking bar should show the ''Main'' menu.'
+ type: #Boolean>
+ ^ self getMenuPreference: #showMainMenuInWorldMainDockingBar ifAbsent: [true]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showMainMenuInWorldMainDockingBar: (in category 'preferences') -----
+ showMainMenuInWorldMainDockingBar: aBoolean
+
+ self
+ setMenuPreference: #showMainMenuInWorldMainDockingBar
+ to: aBoolean.
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showProjectsMenuInWorldMainDockingBar (in category 'preferences') -----
+ showProjectsMenuInWorldMainDockingBar
+
+ <preference: 'Show ''Projects'' menu in world main docking bar'
+ category: 'docking bars'
+ description: 'Whether world''s main docking bar should show the ''Projects'' menu.'
+ type: #Boolean>
+ ^ self getMenuPreference: #showProjectsMenuInWorldMainDockingBar ifAbsent: [true]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showProjectsMenuInWorldMainDockingBar: (in category 'preferences') -----
+ showProjectsMenuInWorldMainDockingBar: aBoolean
+
+ self
+ setMenuPreference: #showProjectsMenuInWorldMainDockingBar
+ to: aBoolean.
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showToolsMenuInWorldMainDockingBar (in category 'preferences') -----
+ showToolsMenuInWorldMainDockingBar
+
+ <preference: 'Show ''Tools'' menu in world main docking bar'
+ category: 'docking bars'
+ description: 'Whether world''s main docking bar should show the ''Tools'' menu.'
+ type: #Boolean>
+ ^ self getMenuPreference: #showToolsMenuInWorldMainDockingBar ifAbsent: [true]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showToolsMenuInWorldMainDockingBar: (in category 'preferences') -----
+ showToolsMenuInWorldMainDockingBar: aBoolean
+
+ self
+ setMenuPreference: #showToolsMenuInWorldMainDockingBar
+ to: aBoolean.
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showWindowsMenuInWorldMainDockingBar (in category 'preferences') -----
+ showWindowsMenuInWorldMainDockingBar
+
+ <preference: 'Show ''Windows'' menu in world main docking bar'
+ category: 'docking bars'
+ description: 'Whether world''s main docking bar should show the ''Windows'' menu.'
+ type: #Boolean>
+ ^ self getMenuPreference: #showWindowsMenuInWorldMainDockingBar ifAbsent: [true]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showWindowsMenuInWorldMainDockingBar: (in category 'preferences') -----
+ showWindowsMenuInWorldMainDockingBar: aBoolean
+
+ self
+ setMenuPreference: #showWindowsMenuInWorldMainDockingBar
+ to: aBoolean.
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showWorldMainDockingBar (in category 'preferences') -----
+ showWorldMainDockingBar
+
+ <preference: 'Show world main docking bar'
+ category: 'docking bars'
+ description: 'Whether world''s main docking bar should be shown or not.'
+ type: #Boolean>
+ ^Project current showWorldMainDockingBar!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>showWorldMainDockingBar: (in category 'preferences') -----
+ showWorldMainDockingBar: aBoolean
+
+ Project current showWorldMainDockingBar: aBoolean!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>timeStamp (in category 'timestamping') -----
+ timeStamp
+ "Answer the receiver's timeStamp"
+ ^ TS!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>updateInstances (in category 'events') -----
+ updateInstances
+ "The class has changed, time to update the instances"
+
+ self setTimeStamp.
+ Project current assureMainDockingBarPresenceMatchesPreference!
Item was added:
+ ----- Method: TheWorldMainDockingBar class>>updateInstances: (in category 'events') -----
+ updateInstances: anEvent
+ "The class has changed, time to update the instances"
+ (anEvent itemClass == self
+ or: [anEvent itemClass == self class])
+ ifFalse: [^ self].
+ ""
+ self updateInstances!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>aboutMenuItemOn: (in category 'submenu - squeak') -----
+ aboutMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'About Squeak...' translated;
+ target: self;
+ selector: #aboutSqueak ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>aboutSqueak (in category 'menu actions') -----
+ aboutSqueak
+ false
+ ifTrue:
+ [UserDialogBoxMorph
+ inform: Smalltalk systemInformationString withCRs
+ title: 'About Squeak...' translated
+ at: World center]
+ ifFalse:
+ [| m |
+ m := SystemReporter open.
+ m label: 'About Squeak...' translated.
+ m setConstrainedPosition: World center - (m bounds extent / 2)
+ hangOut: false]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>allOtherWindowsLike: (in category 'submenu - windows') -----
+ allOtherWindowsLike: window
+ ^ self allVisibleWindows reject: [:each |
+ each model name ~= window model name or: [each = window]]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>allVisibleWindows (in category 'submenu - windows') -----
+ allVisibleWindows
+ ^SystemWindow windowsIn: World satisfying: [ :w | w visible ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>allWindowsLike: (in category 'submenu - windows') -----
+ allWindowsLike: window
+ ^ self allVisibleWindows reject: [:each | each model ~= window model or: [each = window]]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>appsMenuOn: (in category 'submenu - apps') -----
+ appsMenuOn: aDockingBar
+ "Create a menu with the registered apps"
+
+ aDockingBar addItem: [ :item |
+ item
+ contents: 'Apps' translated;
+ subMenuUpdater: self
+ selector: #listAppsOn: ]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar>>browserMenuItemOn: (in category 'submenu - tools') -----
+ browserMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Browser' translated;
+ help: 'Open a browser' translated;
+ icon: (self colorIcon: Preferences browserWindowColor);
+ target: StandardToolSet;
+ selector: #openClassBrowser ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>clockOn: (in category 'right side') -----
+ clockOn: aDockingBar
+ aDockingBar
+ addMorphBack: ClockMorph new ;
+ addDefaultSpace!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>closeAllWindows (in category 'submenu - windows') -----
+ closeAllWindows
+ self allVisibleWindows do: [:each |
+ each model canDiscardEdits ifTrue: [each delete]]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>closeAllWindowsBut: (in category 'submenu - windows') -----
+ closeAllWindowsBut: window
+ (self allOtherWindowsLike: window) do: [:each |
+ each model canDiscardEdits ifTrue: [each delete]]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>closeAllWindowsButWorkspaces (in category 'submenu - windows') -----
+ closeAllWindowsButWorkspaces
+
+ (UserDialogBoxMorph
+ confirm: 'There might be unsaved changes.\Do you really want to close all windows\that are no workspaces?' withCRs
+ title: 'Only keep workspaces') ifTrue: [
+ self allVisibleWindows
+ reject: [:each | each model isKindOf: Workspace]
+ thenDo: [:each | [each delete] valueSupplyingAnswer: true]].!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>closeAllWindowsLike: (in category 'submenu - windows') -----
+ closeAllWindowsLike: window
+ self closeAllWindowsBut: window.
+ window model canDiscardEdits ifTrue: [window delete]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>closeAllWindowsUnsafe (in category 'submenu - windows') -----
+ closeAllWindowsUnsafe
+
+ (UserDialogBoxMorph
+ confirm: 'There might be unsaved changes.\Do you really want to close all windows?' withCRs
+ title: 'Close All Windows') ifTrue: [
+ self allVisibleWindows do: [:each | [each delete] valueSupplyingAnswer: true]].!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>colorIcon: (in category 'private') -----
+ colorIcon: aColor
+
+ "Guess if 'uniform window colors' are used and avoid all icons to be just gray"
+ (aColor = Preferences uniformWindowColor or: [Preferences tinyDisplay]) ifTrue: [ ^nil ].
+ ^(aColor iconOrThumbnailOfSize: 14)
+ borderWidth: 3 color: Preferences menuColor muchDarker;
+ borderWidth: 2 color: Color transparent!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>createDockingBar (in category 'construction') -----
+ createDockingBar
+ "Create a docking bar from the receiver's representation"
+
+ | dockingBar |
+ dockingBar := DockingBarMorph new
+ adhereToTop;
+ color: Preferences menuColor;
+ gradientRamp: self gradientRamp;
+ autoGradient: MenuMorph gradientMenu;
+ borderWidth: 0.
+ self fillDockingBar: dockingBar.
+ self labelIfNeeded: dockingBar.
+ ^ dockingBar!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>dualChangeSorterMenuItemOn: (in category 'submenu - tools') -----
+ dualChangeSorterMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Dual Change Sorter' translated;
+ help: 'Open a Dual Change Sorter' translated;
+ icon: (self colorIcon: ChangeSorter basicNew defaultBackgroundColor);
+ target: DualChangeSorter;
+ selector: #open ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>extendingTheSystem (in category 'submenu - help') -----
+ extendingTheSystem
+ ^'SqueakMap is an integrated catalog of external applications for Squeak. It is accessible from the "Apps" menu. This catalog does not host the projects, it merely documents the load scripts required to correctly bring them into the image.
+
+ Many SqueakMap packages use Installer, which defines several packages in its package-definitions protocol. Any of these can be loaded with an expression like the following:
+
+ Installer new merge: #openGL
+
+ Change #openGL to the selector name of the package you want to load. The latest version of that package and all of its prerequisites will be merged into the image. Merging a package is no different from loading it unless the package is already loaded, in which case it is upgraded to the latest version in a way that preserves any local changes you may already have made.
+
+ ---------------
+ This remainder of this workspace documents load-scripts for packages that are not documented in either SqueakMap or Installer.
+
+ OCompletion
+ "Provides source code completion as you type"
+ (Installer ss project: ''OCompletion'') install: ''Ocompletion''.
+ (Smalltalk at: #ECToolSet) register.
+ (Smalltalk at: #ToolSet) default: (Smalltalk at: #ECToolSet).
+
+ Omnibrowser
+ "Including Refactoring engine"
+ (Installer ss project: ''MetacelloRepository'') install: ''ConfigurationOfOmniBrowser''.
+ ((Smalltalk at: #ConfigurationOfOmniBrowser) project perform: #lastVersion) load: #( Dev ).
+
+ Pier CMS
+ "Pier CMS: http://www.piercms.com"
+ (Installer ss project: ''MetacelloRepository'') install: ''ConfigurationOfPier2''.
+ (Smalltalk at: #ConfigurationOfPier2) load.
+
+ (Installer lukas project: ''pier2'') install: ''Pier-Blog''.
+ (Installer lukas project: ''pier2'') install: ''Pier-Book''.
+ (Installer lukas project: ''pier2addons'') install: ''Pier-Setup''.
+ (Smalltalk at: #PRDistribution) new register.
+
+ Open Cobalt
+ "http://opencobalt.org (Best to run this from an image in an open cobalt directory)"
+ Installer ss project: ''TweakCore''; install: ''update''.
+ [Installer ss project: ''TweakExtras''; install: ''update'']
+ on: (Smalltalk at: #CUnsynchronizedModification) do: [:ex | ex resume].
+ Installer cobalt project: ''Tweak'';
+ answer: ''Would you like to conserve memory at all costs?'' with: true;
+ answer: ''Password for interactive VNC connections?'' with: ''cobalt'';
+ answer: ''Would you like to add the RFBServer to the World open menu?'' with: true;
+ install: ''update''
+ !!
+ ]style[(9 309 19 252 6 126 8 237 11 209 11 210 8 386 11 547)dSMLoaderPlus open;;,,d| newBrowser |
+ newBrowser := Browser new selectSystemCategory: ''Installer-Core''; selectClass: Installer; metaClassIndicated: false; selectMessageCategoryNamed: ''package-definitions''; selectMessageNamed: #openGL.
+ Browser openBrowserView: (newBrowser openMessageCatEditString: nil) label: ''External Package Definitions'';;,,i,,u,,bu,,bu,,bu,,bu,!!' readStream nextChunkText!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>extrasMenuOn: (in category 'submenu - extras') -----
+ extrasMenuOn: aDockingBar
+
+ aDockingBar addItem: [ :it|
+ it contents: 'Extras' translated;
+ addSubMenu: [:menu|
+ menu addItem:[:item|
+ item
+ contents: 'Recover Changes' translated;
+ help: 'Recover changes after a crash' translated;
+ icon: MenuIcons smallHelpIcon;
+ target: ChangeList;
+ selector: #browseRecentLog].
+ menu addLine.
+ menu addItem:[:item|
+ item
+ contents: 'Window Colors' translated;
+ help: 'Changes the window color scheme' translated;
+ addSubMenu:[:submenu| self windowColorsOn: submenu]].
+ menu addItem:[:item|
+ item
+ contents: 'Set Author Initials' translated;
+ help: 'Sets the author initials' translated;
+ target: Utilities;
+ selector: #setAuthorInitials].
+ menu addItem:[:item|
+ item
+ contents: 'Restore Display (r)' translated;
+ help: 'Redraws the entire display' translated;
+ target: World;
+ selector: #restoreMorphicDisplay].
+ menu addItem:[:item|
+ item
+ contents: 'Rebuild Menus' translated;
+ help: 'Rebuilds the menu bar' translated;
+ target: TheWorldMainDockingBar;
+ selector: #updateInstances].
+ menu addLine.
+ menu addItem:[:item|
+ item
+ contents: 'Start Profiler' translated;
+ help: 'Starts the profiler' translated;
+ target: self;
+ selector: #startMessageTally].
+ menu addItem:[:item|
+ item
+ contents: 'Collect Garbage' translated;
+ help: 'Run the garbage collector and report space usage' translated;
+ target: Utilities;
+ selector: #garbageCollectAndReport].
+ menu addItem:[:item|
+ item
+ contents: 'Purge Undo Records' translated;
+ help: 'Save space by removing all the undo information remembered in all projects' translated;
+ target: CommandHistory;
+ selector: #resetAllHistory].
+ menu addItem:[:item|
+ item
+ contents: 'VM statistics' translated;
+ help: 'Virtual Machine information' translated;
+ target: self;
+ selector: #vmStatistics].
+ menu addLine.
+ menu addItem:[:item|
+ item
+ contents: 'Graphical Imports' translated;
+ help: 'View the global repository called ImageImports; you can easily import external graphics into ImageImports via the FileList' translated;
+ target: (Imports default);
+ selector: #viewImages].
+ menu addItem:[:item|
+ item
+ contents: 'Standard Graphics Library' translated;
+ help: 'Lets you view and change the system''s standard library of graphics' translated;
+ target: ScriptingSystem;
+ selector: #inspectFormDictionary].
+ menu addItem:[:item|
+ item
+ contents: 'Annotation Setup' translated;
+ help: 'Click here to get a little window that will allow you to specify which types of annotations, in which order, you wish to see in the annotation panes of browsers and other tools' translated;
+ target: Preferences;
+ selector: #editAnnotations].
+ menu addItem:[:item|
+ item
+ contents: 'Browse My Changes' translated;
+ help: 'Browse all of my changes since the last time #condenseSources was run.' translated;
+ target: SystemNavigation new;
+ selector: #browseMyChanges].
+ ] ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>fileListMenuItemOn: (in category 'submenu - tools') -----
+ fileListMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'File List' translated;
+ help: 'Open a file list' translated;
+ icon: (self colorIcon: Preferences fileListWindowColor);
+ target: StandardToolSet;
+ selector: #openFileList ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>fillDockingBar: (in category 'construction') -----
+ fillDockingBar: aDockingBar
+ "Private - fill the given docking bar"
+
+ self menusOn: aDockingBar.
+ aDockingBar addSpacer.
+ self projectNameOn: aDockingBar.
+ aDockingBar addSpacer.
+ self rightSideOn: aDockingBar.
+ aDockingBar
+ setProperty: #mainDockingBarTimeStamp
+ toValue: self class timeStamp.!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>gradientRamp (in category 'private') -----
+ gradientRamp
+
+ ^{
+ 0.0 -> Color white.
+ 1.0 -> Preferences menuColor darker }!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>helpMenuOn: (in category 'submenu - help') -----
+ helpMenuOn: aDockingBar
+
+ aDockingBar addItem: [ :it |
+ it contents: 'Help' translated;
+ addSubMenu: [ :menu | 'Todo'.
+ menu addItem:[:item|
+ item
+ contents: 'Online Resources' translated;
+ help: 'Online resources for Squeak' translated;
+ target: self;
+ icon: MenuIcons smallHelpIcon;
+ selector: #showWelcomeText:label:in:;
+ arguments: {
+ #squeakOnlineResources.
+ 'Squeak Online Resources'.
+ (140 at 140 extent: 560 at 360)
+ }].
+ menu addItem:[:item|
+ item
+ contents: 'Keyboard Shortcuts' translated;
+ help: 'Keyboard bindings used in Squeak' translated;
+ target: Utilities;
+ selector: #openCommandKeyHelp ].
+ menu addItem:[:item|
+ item
+ contents: 'Font Size Summary' translated;
+ help: 'Font size summary from the old Squeak 3.10.2 help menu.' translated;
+ target: TextStyle;
+ selector: #fontSizeSummary ].
+ menu addItem:[:item|
+ item
+ contents: 'Useful Expressions' translated;
+ help: 'Useful expressions from the old Squeak 3.10.2 help menu.' translated;
+ target: Utilities;
+ selector: #openStandardWorkspace ].
+ (Smalltalk classNamed: #SystemReporter) ifNotNil: [:classSystemReporter |
+ menu addItem: [:item |
+ item
+ contents: 'About this System' translated;
+ help: 'SystemReporter status of the image and runtime environment' translated;
+ target: classSystemReporter;
+ selector: #open]].
+ menu addLine.
+ menu addItem:[:item|
+ item
+ contents: 'Extending the system' translated;
+ help: 'Includes code snippets to evaluate for extending the system' translated;
+ target: self;
+ icon: MenuIcons smallHelpIcon;
+ selector: #showWelcomeText:label:in:;
+ arguments: {
+ #extendingTheSystem.
+ 'How to extend the system'.
+ (140 at 140 extent: 560 at 360)
+ }].
+ menu addLine.
+ menu addItem:[:item|
+ item
+ contents: 'Welcome Workspaces' translated;
+ help: 'The Welcome Workspaces' translated;
+ addSubMenu:[:submenu| self welcomeWorkspacesOn: submenu]].
+ (Smalltalk classNamed: #HelpBrowser) ifNotNil: [:classHelpBrowser |
+ (Smalltalk classNamed: #TerseGuideHelp) ifNotNil: [:classTerseGuideHelp |
+ menu addLine.
+ menu addItem: [:item |
+ item
+ contents: 'Terse Guide to Squeak' translated;
+ help: 'Concise information about language and environment' translated;
+ target: classHelpBrowser;
+ selector: #openOn:;
+ arguments: { classTerseGuideHelp }]].
+ menu addLine.
+ menu addItem: [:item |
+ item
+ contents: 'Help Browser' translated;
+ help: 'Integrated Help System' translated;
+ target: classHelpBrowser;
+ selector: #open]]]]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>jumpToProjectMenuItemOn: (in category 'submenu - projects') -----
+ jumpToProjectMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Jump To Project' translated;
+ icon: MenuIcons smallProjectJumpIcon;
+ subMenuUpdater: self
+ selector: #updateJumpToProjectSubMenu: ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>labelIfNeeded: (in category 'private') -----
+ labelIfNeeded: aDockingBar
+ "Label the given docking bar with the project name, if needed"
+ (aDockingBar submorphWithProperty: #projectNameMorph)
+ contents: (Project current isTopProject ifTrue: [''] ifFalse: [Project current name]);
+ fitContents!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>licenseInformation (in category 'submenu - help') -----
+ licenseInformation
+ "Should NOT be edited interactively"
+ ^Smalltalk license asText!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>listAppsOn: (in category 'submenu - apps') -----
+ listAppsOn: menu
+ "Update the apps list in the menu"
+
+ | args |
+ TheWorldMenu registeredOpenCommands do:[:spec|
+ args := spec second.
+ menu addItem: [ :item |
+ item
+ contents: spec first translated;
+ target: args first;
+ selector: args second].
+ ].
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar>>listWindowsOn: (in category 'submenu - windows') -----
+ listWindowsOn: menu
+
+ | windows |
+ windows := SortedCollection sortBlock: [:winA :winB |
+ winA model name = winB model name
+ ifTrue: [winA label < winB label]
+ ifFalse: [winA model name < winB model name]].
+ windows addAll: self allVisibleWindows.
+ windows ifEmpty: [
+ menu addItem: [ :item |
+ item
+ contents: 'No Windows' translated;
+ isEnabled: false ] ].
+ windows do: [ :each |
+ menu addItem: [ :item |
+ item
+ contents: (self windowMenuItemLabelFor: each);
+ icon: (self colorIcon: each model defaultBackgroundColor);
+ target: each;
+ selector: #comeToFront;
+ subMenuUpdater: self
+ selector: #windowMenuFor:on:
+ arguments: { each };
+ action: [ each activateAndForceLabelToShow; expand ] ] ].
+ menu
+ addLine;
+ add: 'Close all windows' target: self selector: #closeAllWindowsUnsafe;
+ add: 'Close all windows w/o changes' target: self selector: #closeAllWindows;
+ add: 'Close all windows but workspaces' target: self selector: #closeAllWindowsButWorkspaces.!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>loadProject (in category 'menu actions') -----
+ loadProject
+
+ World worldMenu loadProject!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>loadProjectMenuItemOn: (in category 'submenu - projects') -----
+ loadProjectMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Load Project' translated;
+ help: 'Load a project from a file' translated;
+ icon: MenuIcons smallProjectLoadIcon;
+ target: self;
+ selector: #loadProject ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>menusOn: (in category 'construction') -----
+ menusOn: aDockingBar
+
+ self class showMainMenuInWorldMainDockingBar ifTrue: [
+ self squeakMenuOn: aDockingBar].
+
+ self class showProjectsMenuInWorldMainDockingBar ifTrue: [
+ self projectsMenuOn: aDockingBar].
+
+ self class showToolsMenuInWorldMainDockingBar ifTrue: [
+ self toolsMenuOn: aDockingBar].
+
+ self class showAppsMenuInWorldMainDockingBar ifTrue: [
+ self appsMenuOn: aDockingBar].
+
+ self class showExtrasMenuInWorldMainDockingBar ifTrue: [
+ self extrasMenuOn: aDockingBar].
+
+ self class showWindowsMenuInWorldMainDockingBar ifTrue: [
+ self windowsMenuOn: aDockingBar].
+
+ self class showHelpMenuInWorldMainDockingBar ifTrue: [
+ self helpMenuOn: aDockingBar].!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>methodFinderMenuItemOn: (in category 'submenu - tools') -----
+ methodFinderMenuItemOn: menu
+
+ menu addItem: [:item |
+ item
+ contents: 'Method Finder' translated;
+ help: 'Open the Method Finder' translated;
+ icon: (self colorIcon: Preferences methodFinderWindowColor);
+ target: StandardToolSet;
+ selector: #openSelectorBrowser]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>monticelloBrowserMenuItemOn: (in category 'submenu - tools') -----
+ monticelloBrowserMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Monticello Browser' translated;
+ help: 'Open a Monticello Browser' translated;
+ icon: (self colorIcon: MCTool basicNew defaultBackgroundColor);
+ target: MCWorkingCopyBrowser;
+ selector: #open ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>monticelloConfigurationsMenuItemOn: (in category 'submenu - tools') -----
+ monticelloConfigurationsMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Monticello Configurations' translated;
+ help: 'Open a Monticello Configurations Editor' translated;
+ icon: (self colorIcon: MCConfigurationBrowser basicNew defaultBackgroundColor);
+ target: MCConfigurationBrowser;
+ selector: #open ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>newProject: (in category 'menu actions') -----
+ newProject: projectClass
+ "Create a new project of the given type"
+ | newProject |
+ "Allow the project to return nil from #new to indicate that it was canceled."
+ newProject := projectClass new ifNil:[^self].
+ ProjectViewMorph openOn: newProject.
+ newProject enter.!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>newProjectMenuItemOn: (in category 'submenu - projects') -----
+ newProjectMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'New Project' translated;
+ help: 'Start a new MorphicProject' translated;
+ icon: MenuIcons smallProjectIcon;
+ target: self;
+ selector: #newProject:;
+ arguments: { MorphicProject };
+ subMenuUpdater: self
+ selector: #updateNewProjectSubMenu: ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>preferenceBrowserMenuItemOn: (in category 'submenu - tools') -----
+ preferenceBrowserMenuItemOn: menu
+ Smalltalk at: #PreferenceBrowser ifPresent:[:pb|
+ menu addItem: [ :item |
+ item
+ contents: 'Preferences' translated;
+ help: 'Open a Preferences Browser' translated;
+ icon: (self colorIcon: pb basicNew defaultBackgroundColor);
+ target: pb;
+ selector: #open ]
+ ].!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>previousProjectMenuItemOn: (in category 'submenu - projects') -----
+ previousProjectMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Previous Project' translated;
+ help: 'Return to the most-recently-visited project' translated;
+ icon: MenuIcons smallProjectBackIcon;
+ target: World;
+ selector: #goBack ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>processBrowserMenuItemOn: (in category 'submenu - tools') -----
+ processBrowserMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Process Browser' translated;
+ help: 'Open a Process Browser' translated;
+ icon: (self colorIcon: ProcessBrowser basicNew defaultBackgroundColor);
+ target: ProcessBrowser;
+ selector: #open ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>projectNameOn: (in category 'right side') -----
+ projectNameOn: aDockingBar
+ | morph |
+ morph := StringMorph contents: ''.
+ morph setProperty: #projectNameMorph toValue: #projectNameMorph.
+ aDockingBar addMorphBack: morph.
+ self labelIfNeeded: aDockingBar!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>projectsMenuOn: (in category 'construction') -----
+ projectsMenuOn: aDockingBar
+
+ aDockingBar addItem: [ :item |
+ item
+ contents: 'Projects' translated;
+ addSubMenu: [ :menu |
+ self
+ newProjectMenuItemOn: menu;
+ saveProjectMenuItemOn: menu;
+ loadProjectMenuItemOn: menu;
+ previousProjectMenuItemOn: menu;
+ jumpToProjectMenuItemOn: menu ] ]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar>>quitMenuItemOn: (in category 'submenu - squeak') -----
+ quitMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Quit' translated;
+ help: 'Quit out of Squeak' translated;
+ icon: MenuIcons smallQuitNoSaveIcon;
+ target: self;
+ selector: #quitSqueak ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>quitSqueak (in category 'menu actions') -----
+ quitSqueak
+
+ ^Smalltalk
+ snapshot: (
+ UserDialogBoxMorph
+ confirm: 'Save changes before quitting?' translated
+ orCancel: [ ^self ]
+ at: World center)
+ andQuit: true
+
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar>>releaseNotes (in category 'submenu - help') -----
+ releaseNotes
+ ^'Squeak 4.5 ---- Theodor
+ ===================
+
+ ______________________________________________
+ Language enhancements:
+
+ Environments
+ Environments allows multiple classes with the same name to exist in the same image, with code referencing through its class'' "environment".
+
+ Collections
+ New and improved sorting utilities for Arrays and OrderedCollections.
+ New FloatCollection inherits the convenient add:/remove: API of OrderedCollection, but using an internal FloatArray for better efficiency.
+ An all-new LRUCache implementation.
+ Promise is now a fully chainable object with decent error handling.
+ Compiler
+
+ Numerics
+ Faster and better Random.
+ log/ln fixed for integers.
+
+ Dates and Times
+ New methods provide access to primitive 240 and 241, which can provide microsecond resolution timestamps on Cog VMs.
+ New convenience methods allow creating DateAndTimes relative to now (e.g., "5 minutes ago").
+ Parsing improvements.
+
+ Text, Graphics, Sound
+ Form>pixelValueAt: now makes use of the new primitivePixelValueAt:, avoiding the overhead of a full BitBlt.
+ Elimination of the dual hierarchy of NewParagraph & MultiNewParagraph etc and TextStopConditions and lots of Scanner improvements.
+ PaintBoxMorph re-engineering.
+ ADPCMCodec performance improvement.
+
+ ______________________________________________
+ IDE, Monticello and Trunk process improvements:
+
+ Several MVC fixes allow debugging in MVC once again.
+ Smart-Splitters causes the bars between browser panes to automatically optimize their position.
+ Fixed color-selection from anywhere on the screen working again.
+ Improved command-line interface via Smalltalk run: [ :arg1 :arg2 | ... ].
+ squeakDebug.log report length is now settable.
+ MCReorganizationPreloader now resolves moves between arbitrary packages, independent of their order in the configuration.
+ mcz/snapshot/source.st now encoded in UTF8 instead of latin-1.
+ New pre-selection highlight feature for lists.
+ System space analysis now available in Help | About.
+ Message-traces can be pared more easily.
+
+ ______________________________________________
+ Configuration
+ Lots of improvements in the CI build/test slave.
+ Installer now documents externally-loadable packages as simple literal structures that can be merged via Installer>>#merge:.
+ MC ancestry history strings can now be stubbed for a smaller image and sustainable MC history.
+
+ ______________________________________________
+ History and Accounting Tools
+ A great new historical website by Bob Arning.
+ MC history and origin is now available for methods and class-definitions from browser menus.
+ A new amazing ObjectHistory makes it possible to efficiently track the born-on date of any object to a resolution of one minute.
+ Added "search history" to Package history browser.
+
+ ______________________________________________
+ Fixes and cleanups
+ Packages organized toward eliminating circular dependencies, and with proper concern for existing and future UI frameworks.
+ Updated uses of SmalltalkImage current to, simply, "Smalltalk."
+ Moving away from use of Utilities.
+ More preferences made pragma-based.
+ Compiler factorings and cleanups.
+ Diminished excessive usage of ReadWriteStream.
+ ProtoObject API balanced and minimal.
+ Moved classifying and logging behavior out of Compiler (a responsibility of Behavior).
+
+ ______________________________________________
+ Application Upgrade Notes
+ Default Float printing is now true to its internal representation. Apps must now use appropriate methods to format Floats rather than roundTo:.
+ ($a to: $b) now returns ''ab'' rather than #($a $b).
+ Remove OneCharacterSymbols optimization.
+ LRUCache instance migrations, if any. See post-scripts in Collections-ul.546, 547
+ Rectangles with 0 area (e.g., lines) can now intersect.
+
+
+
+ This release is dedicated
+ to the memory of our friend
+ Andreas Raab (1968 -- 2013)
+ !!
+ ]style[(10 1 4 1 7 1 19 1 1 47 22 2 13 142 11 329 8 57 15 237 21 358 48 720 13 321 28 372 18 522 25 382 1 5 7 4 9 56 1)ba2FBitstreamVeraSerif#32.0,a2FBitstreamVeraSerif#32.0,a2--FBitstreamVeraSerif#32.0,a2FBitstreamVeraSerif#32.0,ia2FBitstreamVeraSerif#32.0,FBitstreamVeraSerif#24.0a2,FBitstreamVeraSerif#24.0----a2,FBitstreamVeraSerif#24.0a2,,FBitstreamVeraSerif#16.0,FBitstreamVeraSerif#24.0,,bFBitstreamVeraSerif#16.0,FBitstreamVeraSerif#16.0,bFBitstreamVeraSerif#16.0,FBitstreamVeraSerif#16.0,bFBitstreamVeraSerif#16.0,FBitstreamVeraSerif#16.0,bFBitstreamVeraSerif#16.0,FBitstreamVeraSerif#16.0,bFBitstreamVeraSerif#16.0,FBitstreamVeraSerif#16.0,FBitstreamVeraSerif#24.0,FBitstreamVeraSerif#16.0,FBitstreamVeraSerif#24.0,FBitstreamVeraSerif#16.0,FBitstreamVeraSerif#24.0,FBitstreamVeraSerif#16.0,FBitstreamVeraSerif#24.0,FBitstreamVeraSerif#16.0,FBitstreamVeraSerif#24.0,FBitstreamVeraSerif#16.0,,FBitstreamVeraSerif#16.0ia2,FBitstreamVeraSerif#16.0iba2,FBitstreamVeraSerif#16.0ia2,FBitstreamVeraSerif#16.0iba2,FBitstreamVeraSerif#16.0ia2,!!' readStream nextChunkText!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>rightSideOn: (in category 'construction') -----
+ rightSideOn: aDockingBar
+
+ self
+ searchBarOn: aDockingBar;
+ clockOn: aDockingBar;
+ toggleFullScreenOn: aDockingBar.!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>save (in category 'menu actions') -----
+ save
+
+ Smalltalk snapshot: true andQuit: false!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>saveAndQuitMenuItemOn: (in category 'submenu - squeak') -----
+ saveAndQuitMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Save And Quit' translated;
+ help: 'Save the current state of Squeak on disk, and quit out of Squeak' translated;
+ icon: MenuIcons smallQuitIcon;
+ target: self;
+ selector: #saveAndQuitSqueak ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>saveAndQuitSqueak (in category 'menu actions') -----
+ saveAndQuitSqueak
+
+ Smalltalk snapshot: true andQuit: true!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>saveAsMenuItemOn: (in category 'submenu - squeak') -----
+ saveAsMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Save Image As...' translated;
+ help: 'Save the current state of Squeak on disk under a new name' translated;
+ icon: MenuIcons smallSaveAsIcon;
+ target: self;
+ selector: #saveImageAs ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>saveAsNewVersion (in category 'menu actions') -----
+ saveAsNewVersion
+
+ Smalltalk saveAsNewVersion!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>saveAsNewVersionMenuItemOn: (in category 'submenu - squeak') -----
+ saveAsNewVersionMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Save As New Version' translated;
+ help: 'Save the current state of Squeak on disk under a version-stamped name' translated;
+ icon: MenuIcons smallSaveNewIcon;
+ target: self;
+ selector: #saveAsNewVersion ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>saveImage (in category 'menu actions') -----
+ saveImage
+
+ Smalltalk saveSession!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>saveImageAs (in category 'menu actions') -----
+ saveImageAs
+
+ Smalltalk saveAs!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>saveMenuItemOn: (in category 'submenu - squeak') -----
+ saveMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Save Image' translated;
+ help: 'Save the current state of Squeak on disk' translated;
+ icon: MenuIcons smallSaveIcon;
+ target: self;
+ selector: #saveImage ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>saveProjectMenuItemOn: (in category 'submenu - projects') -----
+ saveProjectMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Save Project' translated;
+ help: 'Save this project on a file' translated;
+ icon: MenuIcons smallProjectSaveIcon;
+ target: World;
+ selector: #saveOnFile ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>searchBarOn: (in category 'right side') -----
+ searchBarOn: aDockingBar
+
+ aDockingBar
+ addMorphBack: (SearchBar build vResizing: #spaceFill; width: 200);
+ addDefaultSpace!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>showSqueakResources (in category 'submenu - help') -----
+ showSqueakResources
+ ^(StringHolder new contents:
+ 'Squeak web sites:
+ http://www.squeak.org - The main Squeak site.
+ http://news.squeak.org - The Weekly Squeak
+ http://board.squeak.org - The Squeak Oversight Board
+ http://ftp.squeak.org - Downloads for many Squeak versions.
+ http://squeakvm.org - Development of the Squeak virtual machine
+
+ Squeak-dev - The main Squeak mailing list.
+ http://lists.squeakfoundation.org/mailman/listinfo/squeak-dev
+ http://dir.gmane.org/gmane.comp.lang.smalltalk.squeak.general
+ http://n4.nabble.com/Squeak-Dev-f45488.html
+
+ Squeak-Beginners - The place to ask even the most basic questions.
+ http://lists.squeakfoundation.org/mailman/listinfo/beginners
+ http://dir.gmane.org/gmane.comp.lang.smalltalk.squeak.beginners
+ http://n4.nabble.com/Squeak-Beginners-f107673.html
+
+ Squeak By Example:
+ http://www.squeakbyexample.org/
+
+ Squeak, Open Personal Computing and Multimedia (The NuBlue Book - Draft):
+ http://coweb.cc.gatech.edu/squeakbook/
+ http://stephane.ducasse.free.fr/FreeBooks/CollectiveNBlueBook/
+
+ Squeak, Open Personal Computing for Multimedia (The White Book - Draft):
+ http://www.cc.gatech.edu/~mark.guzdial/drafts/
+ http://stephane.ducasse.free.fr/FreeBooks/GuzdialBookDrafts/
+
+ More Books about Squeak and Smalltalk:
+ http://stephane.ducasse.free.fr/FreeBooks.html
+
+ ') openLabel: 'Squeak Online Resources'!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>showWelcomeText:label:in: (in category 'submenu - help') -----
+ showWelcomeText: aSelector label: labelString in: bounds
+ "Show a welcome text. Linked in here so that the text can be edited
+ by changing the acceptBlock below."
+ | acceptBlock window |
+ "Change the following to allow editing the text"
+ true ifTrue:[
+ acceptBlock := [:text|
+ self class
+ compile: aSelector,'
+ ^', (String streamContents:[:s| s nextChunkPutWithStyle: text]) storeString, ' readStream nextChunkText'
+ classified: (self class organization categoryOfElement: aSelector).
+ ].
+ ].
+
+ window := UIManager default
+ edit: (self perform: aSelector)
+ label: labelString
+ accept: acceptBlock.
+ window bounds: bounds.
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar>>simpleChangeSorterMenuItemOn: (in category 'submenu - tools') -----
+ simpleChangeSorterMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Simple Change Sorter' translated;
+ help: 'Open a Change Sorter' translated;
+ icon: (self colorIcon: ChangeSorter basicNew defaultBackgroundColor);
+ target: ChangeSorter;
+ selector: #open ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>squeakMenuOn: (in category 'construction') -----
+ squeakMenuOn: aDockingBar
+ "Private - fill the given docking bar"
+
+ aDockingBar addItem: [ :item |
+ item
+ contents: '';
+ icon: MenuIcons squeakLogoIcon;
+ selectedIcon: MenuIcons squeakLogoInvertedIcon;
+ addSubMenu: [ :menu |
+ self
+ aboutMenuItemOn: menu;
+ updateMenuItemOn: menu.
+ menu addLine.
+ self
+ saveMenuItemOn: menu;
+ saveAsMenuItemOn: menu;
+ saveAsNewVersionMenuItemOn: menu.
+ menu addLine.
+ self
+ saveAndQuitMenuItemOn: menu;
+ quitMenuItemOn: menu ] ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>squeakOnlineResources (in category 'submenu - help') -----
+ squeakOnlineResources
+ ^'Squeak web sites
+ Main Squeak site http://www.squeak.org
+ Weekly Squeak http://news.squeak.org
+ Oversight Board http://board.squeak.org
+ Downloads for many versions http://ftp.squeak.org
+ Development of the virtual machine http://squeakvm.org
+ Google+ Page
+ https://plus.google.com/u/0/b/115950529692424242526/
+
+ Squeak-dev - The main Squeak mailing list
+ http://lists.squeakfoundation.org/mailman/listinfo/squeak-dev
+ http://dir.gmane.org/gmane.comp.lang.smalltalk.squeak.general
+ http://n4.nabble.com/Squeak-Dev-f45488.html
+
+ Squeak-Beginners - The place to ask even the most basic questions
+ http://lists.squeakfoundation.org/mailman/listinfo/beginners
+ http://dir.gmane.org/gmane.comp.lang.smalltalk.squeak.beginners
+ http://n4.nabble.com/Squeak-Beginners-f107673.html
+
+ Squeak By Example
+ http://www.squeakbyexample.org/
+
+ Squeak, Open Personal Computing and Multimedia
+ http://coweb.cc.gatech.edu/squeakbook/
+ http://stephane.ducasse.free.fr/FreeBooks/CollectiveNBlueBook/
+
+ Squeak, Open Personal Computing for Multimedia
+ http://www.cc.gatech.edu/~mark.guzdial/drafts/
+ http://stephane.ducasse.free.fr/FreeBooks/GuzdialBookDrafts/
+
+ More Books about Squeak and Smalltalk
+ http://stephane.ducasse.free.fr/FreeBooks.html
+ !!
+ ]style[(16 316 41 173 65 181 17 35 46 106 46 112 37 49)bu,,bu,,bu,,bu,,bu,,bu,,bu,!!' readStream nextChunkText!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>squeakUserInterface (in category 'submenu - help') -----
+ squeakUserInterface
+ ^'The Squeak UI has some unusual elements that you may not have seen before. Here is a brief introduction to those elements:
+
+ Projects
+ A project is an entire Squeak desktop full of windows. Projects can be used to change quickly from one task to another. An inactive project is represented by a project window, which shows a thumbnail of its state. Project windows are actually more like doors than windows, since you can enter the project just by clicking on them. You can create a new project by choosing ''open...project'' from the screen menu. To exit a project (and return to its parent project), choose ''previous project'' from the screen menu. Each project maintains its own set of windows and other information.
+
+ Morphic Halos
+ In a morphic project, pressing cmd-click (Mac) or alt-click (Windows) on a graphical object (e.g. a window) will surround it with a constellation of colored circles. These are called "halo handles." Additional clicks will cycle through the halos for the other graphical objects in the nesting structure. If you hold down the Shift key while cmd/alt-clicking, the nested morphs will be traversed from innermost outward. Clicking without the cmd/alt key will dismiss the halo. While the halo is up, letting the cursor linger over one of the halo handles for a few seconds will cause a balloon to pop up with the name of that handle. Three useful handles are the top-left "X" handle (delete), the bottom-right yellow handle (resize), and the brown handle (slide the object within its containing object). Halos allow complex graphical objects to be explored - or even disassembled (using the black halo handle). Usually no harm results from taking apart an object; you can just discard the pieces and create a new one.
+
+ Flaps
+ To enable Flaps, click on the desktop to show the world menu, choose the "Flaps..." menu and "show shared tags". Tabs labeled "Squeak", "Tools", "Supplies", etc., will appear along the edges of the Squeak desktop. Click on any tab to open the corresponding flap. Drag a tab to resize the flap and to relocate the tab. Bring up the halo on any tab and click on its menu handle to be presented with many options relating to the flap. Use the "Flaps..." menu, reached via the desktop menu, to control which flaps are visible and for other flap-related options and assistance.
+
+ Parts Bins
+ You can obtain new objects in many ways. The "Objects Catalog" (choose "objects'' from the world menu or open the objects flap) and several of the standard flaps (e.g. "Tools" and "Supplies") serve as "Parts Bins" the for new objects. Drag any icon you see in a Parts Bin and a fresh copy of the kind of object it represents will appear "in your hand"; click to deposit the new object anywhere you wish. You can also add your own objects to any of the flaps - just drag your object over the tab, wait for the flap to pop open, then drop the object at the desired position in the flap.
+ !!
+ ]style[(123 9 663 13 991 5 579 10 589),bu,,bu,,bu,,bu,!!' readStream nextChunkText!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>startMessageTally (in category 'menu actions') -----
+ startMessageTally
+ (self confirm: 'MessageTally will start now,
+ and stop when the cursor goes
+ to the top of the screen') ifTrue:
+ [MessageTally spyOn:
+ [[Sensor peekMousePt y > 0] whileTrue: [World doOneCycle]]]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>testRunnerMenuItemOn: (in category 'submenu - tools') -----
+ testRunnerMenuItemOn: menu
+ Smalltalk at: #TestRunner ifPresent:[:aClass|
+ menu addItem: [ :item |
+ item
+ contents: 'Test Runner' translated;
+ help: 'Open the Test Runner' translated;
+ icon: (self colorIcon: aClass basicNew defaultBackgroundColor);
+ target: aClass;
+ selector: #open ]
+ ].!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>toggleFullScreenOn: (in category 'right side') -----
+ toggleFullScreenOn: aDockingBar
+
+ | toggleMorph box |
+ toggleMorph := (SketchMorph withForm: MenuIcons smallFullscreenOffIcon).
+
+ box := Morph new
+ color: Color transparent;
+ vResizing: #spaceFill;
+ width: toggleMorph width;
+ balloonText: 'toggle full screen mode' translated;
+ addMorph: toggleMorph.
+
+ toggleMorph setToAdhereToEdge: #rightCenter.
+
+ box
+ on: #mouseDown
+ send: #value
+ to:
+ [ Project current toggleFullScreen.
+ toggleMorph form: MenuIcons smallFullscreenOffIcon ] ;
+
+ on: #mouseEnter
+ send: #value
+ to: [toggleMorph form: MenuIcons smallFullscreenOnIcon];
+
+ on: #mouseLeave
+ send: #value
+ to: [toggleMorph form: MenuIcons smallFullscreenOffIcon].
+
+ aDockingBar addMorphBack: box!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>toolsMenuOn: (in category 'construction') -----
+ toolsMenuOn: aDockingBar
+
+ aDockingBar addItem: [ :item |
+ item
+ contents: 'Tools' translated;
+ addSubMenu: [ :menu |
+ self
+ browserMenuItemOn: menu;
+ workspaceMenuItemOn: menu;
+ transcriptMenuItemOn: menu;
+ testRunnerMenuItemOn: menu;
+ methodFinderMenuItemOn: menu.
+ menu addLine.
+ self
+ monticelloBrowserMenuItemOn: menu;
+ monticelloConfigurationsMenuItemOn: menu;
+ simpleChangeSorterMenuItemOn: menu;
+ dualChangeSorterMenuItemOn: menu.
+ menu addLine.
+ self
+ processBrowserMenuItemOn: menu;
+ preferenceBrowserMenuItemOn: menu;
+ fileListMenuItemOn: menu.
+ ] ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>transcriptMenuItemOn: (in category 'submenu - tools') -----
+ transcriptMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Transcript' translated;
+ help: 'Open the Transcript' translated;
+ icon: (self colorIcon: Preferences transcriptWindowColor);
+ target: Transcript;
+ selector: #open ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>updateIfNeeded: (in category 'private') -----
+ updateIfNeeded: aDockingBar
+ "Update the given docking bar if needed"
+ | timeStamp |
+ timeStamp := aDockingBar
+ valueOfProperty: #mainDockingBarTimeStamp
+ ifAbsent: [].
+ timeStamp ~= self class timeStamp
+ ifTrue:
+ [aDockingBar
+ release;
+ removeAllMorphs.
+ self fillDockingBar: aDockingBar]
+ ifFalse:
+ [self labelIfNeeded: aDockingBar]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>updateJumpToProjectSubMenu: (in category 'submenu - projects') -----
+ updateJumpToProjectSubMenu: subMenu
+
+ subMenu defaultTarget: Project.
+ Project current buildJumpToMenu: subMenu!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>updateMenuItemOn: (in category 'submenu - squeak') -----
+ updateMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Update Squeak' translated;
+ help: 'Load latest code updates via the internet' translated;
+ target: self;
+ selector: #updateSqueak ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>updateNewProjectSubMenu: (in category 'submenu - projects') -----
+ updateNewProjectSubMenu: menu
+
+ Project allSubclasses do: [ :each |
+ menu addItem: [ :item |
+ item
+ contents: ('New ', each name) translated;
+ help: ('Start a new ', each name) translated;
+ target: self;
+ selector: #newProject:;
+ arguments: { each } ] ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>updateSqueak (in category 'menu actions') -----
+ updateSqueak
+ MCMcmUpdater updateFromServer.!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>vmStatistics (in category 'menu actions') -----
+ vmStatistics
+ "Open a string view on a report of vm statistics"
+
+ (StringHolder new contents: Smalltalk vmStatisticsReportString)
+ openLabel: 'VM Statistics'!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>welcomeWorkspacesOn: (in category 'submenu - help') -----
+ welcomeWorkspacesOn: menu
+ | versionString | versionString := SystemVersion current version last: 3.
+ menu addItem:[:item|
+ item
+ contents: (versionString, ' Release Notes') translated;
+ help: 'Improvements in this release' translated ;
+ target: self;
+ selector: #showWelcomeText:label:in:;
+ arguments: {
+ #releaseNotes.
+ (versionString, ' Release Notes') translated.
+ (200 at 200 extent: 500 at 300)
+ }].
+ menu addItem:[:item|
+ item
+ contents: 'Working With Squeak' translated;
+ help: 'Information for new users' ;
+ target: self;
+ selector: #showWelcomeText:label:in:;
+ arguments: {
+ #workingWithSqueak.
+ 'Working With Squeak'.
+ (180 at 180 extent: 500 at 300)
+ }].
+ menu addItem:[:item|
+ item
+ contents: 'The Squeak User Interface' translated;
+ help: 'Descriptions of some of the more-unusual UI elements in Squeak' ;
+ target: self;
+ selector: #showWelcomeText:label:in:;
+ arguments: {
+ #squeakUserInterface.
+ 'The Squeak User Interface'.
+ (160 at 160 extent: 500 at 300)
+ }].
+ menu addItem:[:item|
+ item
+ contents: 'License Information' translated;
+ help: String empty ;
+ target: self;
+ selector: #showWelcomeText:label:in:;
+ arguments: {
+ #licenseInformation.
+ 'License Information'.
+ (200 at 200 extent: 500 at 300)
+ }].!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>windowColorsOn: (in category 'construction') -----
+ windowColorsOn: menu
+
+ menu addItem:[:item|
+ item
+ contents: 'Gray Windows' translated;
+ help: 'Use uniform window colors' translated;
+ target: Preferences;
+ selector: #installUniformWindowColors].
+
+ menu addItem:[:item|
+ item
+ contents: 'Colorful Windows' translated;
+ help: 'Use normal window colors' translated;
+ target: Preferences;
+ selector: #installNormalWindowColors].
+
+ menu addLine.
+
+ menu addItem:[:item|
+ item
+ contents: 'Bright-colored Windows' translated;
+ help: 'Use bright window colors' translated;
+ target: Preferences;
+ selector: #installBrightWindowColors].
+
+ menu addItem:[:item|
+ item
+ contents: 'Pastel-colored Windows' translated;
+ help: 'Use pastel window colors' translated;
+ target: Preferences;
+ selector: #installPastelWindowColors].
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar>>windowMenuFor:on: (in category 'submenu - windows') -----
+ windowMenuFor: window on: menu
+ menu
+ addItem: [ :item |
+ item
+ contents: 'Close' translated ;
+ target: window;
+ selector: #delete ];
+ addItem: [ :item |
+ item
+ contents: 'Close all like this' translated ;
+ target: self;
+ selector: #closeAllWindowsLike:;
+ arguments: { window } ];
+ addItem: [ :item |
+ item
+ contents: 'Close all but this' translated ;
+ target: self;
+ selector: #closeAllWindowsBut:;
+ arguments: { window } ];
+ addItem: [ :item |
+ item
+ contents: 'Expand or Contract' translated ;
+ target: window;
+ selector: #expandBoxHit ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>windowMenuItemLabelFor: (in category 'submenu - windows') -----
+ windowMenuItemLabelFor: window
+ | s |
+ s := WriteStream on: String new.
+ window model canDiscardEdits ifFalse: [ s nextPut: $* ].
+ window isCollapsed ifTrue: [ s nextPut: $( ].
+ s nextPutAll: window label.
+ window isCollapsed ifTrue: [ s nextPut: $) ].
+ ^s contents contractTo: 50!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>windowsMenuOn: (in category 'construction') -----
+ windowsMenuOn: aDockingBar
+
+ aDockingBar addItem: [ :item |
+ item
+ contents: 'Windows' translated;
+ subMenuUpdater: self
+ selector: #listWindowsOn: ]
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar>>workingWithSqueak (in category 'submenu - help') -----
+ workingWithSqueak
+ ^'Starting and Quitting
+ Like most Smalltalk''s, the machine-executable portion is a relatively small program known as the "virtual machine" (VM). The VM''s job is to provide services from the physical machine to real Smalltalk objects. Services like input and output. The Smalltalk system, including all data and code, is a system of objects, built from the ground up, and interpreted by this virtual computer. This affords Smalltalk system platform portability.
+
+ Smalltalk cannot run without the VM. The VM can''t do anything useful except process Smalltalk systems.
+
+ To start the system, drag the ".image" data file to the VM executable "squeak". There are myriad command-line options for starting the system via the command-line (see squeak --help). By default, the system will open on the screen in a single OS window.
+
+ To quit a Squeak session, choose ''quit'' from the menu bar. If you save, the image file will be overwritten and resume from that place the next time it''s launched.
+
+ The Image File
+ Squeak is an environment built in its own objects from the ground up, including one or more end-user applications. All of the objects in the system -- Classes, Dictionaries, Windows, Customers and other objects that make up the Squeak environment are stored in a binary ".image" file. This is the "object-data file" loaded by the VM when Squeak is launched.
+
+ When an image is started, every object resumes exactly from where it was last saved.
+
+ The Sources File
+ Smalltalk is traditionally includes the source code in the running system. However, keeping multiple copies of the same source code in all images files is wasteful. Therefore, the source code itself is kept in a read-only .sources file and accessed by all images. The image files merely have pointers into this file, which is read on-the-fly to present original source code.
+
+ The code of the base system is stored in the file "SqueakV41.sources". This file does not change except between releases of Squeak. Normally this file should be placed in the folder containing the VM executable.
+
+ The Changes File
+ The purpose of Squeak is to develop new programs and systems. Code changes to the running system are effective immediately. But since multiple images can be running, they cannot all update the .sources file safely. Therefore, each image file is accompanied by a ".changes" file which contains source code changes for that and only that Smalltalk system..
+
+ The changes file is important for project work. It keeps a sequential log of development activity for the purpose of recovering work performed since the last image-save. Any of several events could lead to the need to recover work, including a power-outage or making an erroneous change to code required to keep the system running.
+
+ The changes file does not consume memory space, so Squeak is able to keep a complete history of all program changes. This makes it easy to examine or even reinstate older versions of methods (see ''versions'' option in browser selector pane). This encourages experimentation, since you can easily revert to the original versions of any set of methods.
+
+ In extreme cases where sources and/or changes files are not available, the system can still run, and will automatically decompile the bytecode methods in image memory, if necessary, into readable and editable versions of the original source code (only comments and temporary variable names are lost).
+
+ Transferring Code-Snippets Between Images
+ In addition to the ''save'' command that saves the entire state of the system, the code of individual methods, categories or classes may be ''filed out'' and then filed-in to another image.
+
+ Packages
+ The code of an entire project is encapsulated by a Package. This allows users to share their code with other users. Code of packages are delineated by the categories of their classes, and methods. The Monticello browser is then used to wrap that code into a Package object which can be saved to a Monticello repository at http://ss3.gemtalksystems.com/ss.
+
+ Some projects end up using the resources provided by several packages, resulting in a hierarchy of packages that make up a system. Installer can be used to install such systems.!!
+ ]style[(21 970 14 448 16 396 11 188 16 321 4 1025 41 188 8 52 10 55 2 420)bu,,bu,,bu,,u,,bu,,u,,bu,,bu,,i,,i,!!' readStream nextChunkText!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>workspaceMenuItemOn: (in category 'submenu - tools') -----
+ workspaceMenuItemOn: menu
+
+ menu addItem: [ :item |
+ item
+ contents: 'Workspace' translated;
+ help: 'Open a Workspace' translated;
+ icon: (self colorIcon: Preferences workspaceWindowColor);
+ target: StandardToolSet;
+ selector: #openWorkspace ]!
Item was added:
+ Object subclass: #TheWorldMenu
+ instanceVariableNames: 'myProject myWorld myHand'
+ classVariableNames: 'OpenMenuRegistry'
+ poolDictionaries: ''
+ category: 'Morphic-Kernel'!
+
+ !TheWorldMenu commentStamp: 'sw 10/5/2002 00:44' prior: 0!
+ Instances of TheWorldMenu serve to present the primary Squeak menu obtained by clicking on open desktop, which is variously spoken of as the "screen menu", the "desktop menu", or the "world menu".
+
+ myProject is the Project I pertain to.
+ myWorld is the world, a PasteUpMorph, that I pertain to.
+ myHand is the hand that invoked the menu.!
Item was added:
+ ----- Method: TheWorldMenu class>>cleanUp (in category 'class initialization') -----
+ cleanUp
+ "Flush out obsolete entries"
+
+ self removeObsolete!
Item was added:
+ ----- Method: TheWorldMenu class>>loadSqueakMap (in category 'open-menu registry') -----
+ loadSqueakMap
+ "Load the externally-maintained SqueakMap package if it is not already loaded. Based on code by Göran Hultgren"
+
+ | server |
+ Socket initializeNetwork.
+ server := #('map1.squeakfoundation.org' 'map2.squeakfoundation.org' 'map.squeak.org' 'map.bluefish.se' 'marvin.bluefish.se:8000')
+ detect: [:srv | | addr answer |
+ addr := NetNameResolver addressForName: (srv upTo: $:) timeout: 5.
+ addr notNil and: [
+ answer := HTTPSocket httpGet: ('http://', srv, '/sm/ping').
+ answer isString not and: [answer contents = 'pong']]]
+ ifNone: [^ self inform: 'Sorry, no SqueakMap master server responding.'].
+ server ifNotNil: ["Ok, found an SqueakMap server"
+ ChangeSet newChangesFromStream:
+ ((('http://', server, '/sm/packagebyname/squeakmap/downloadurl')
+ asUrl retrieveContents content) asUrl retrieveContents content unzipped
+ readStream)
+ named: 'SqueakMap']!
Item was added:
+ ----- Method: TheWorldMenu class>>openPackageLoader (in category 'open-menu registry') -----
+ openPackageLoader
+ "If this method is reached, it means that SMLoader has not yet been loaded; after SqueakMap has come into the image, a different receiver/selector will have been installed under 'Package Loader'; if this method is reached when theoretically SqueakMap is already loaded, presumably this is a grandfathered menu item in a still-up menu, so get the message on to its appropriate recipient."
+
+ | loaderClass |
+ ((loaderClass := Smalltalk at: #SMLoader ifAbsent: [nil]) isKindOf: Class)
+ ifTrue:
+ [^ loaderClass open].
+
+ (self confirm:
+ 'This requires that you first install "SqueakMap" into your image.
+ SqueakMap is a new architecture for finding, installing, and
+ publishing packages in Squeak.
+ Would you like to install SqueakMap now?' )
+ ifTrue:
+ [self loadSqueakMap]!
Item was added:
+ ----- Method: TheWorldMenu class>>registerOpenCommand: (in category 'open-menu registry') -----
+ registerOpenCommand: anArray
+ "The array received should be of form {'A Label String'. {TargetObject. #command} 'A Help String'} ; the final element is optional but if present will be used to supply balloon help for the menu item in the Open menu.
+ If any previous registration of the same label string is already known, delete the old one."
+
+ self unregisterOpenCommand: anArray first.
+ OpenMenuRegistry addLast: anArray!
Item was added:
+ ----- Method: TheWorldMenu class>>registeredOpenCommands (in category 'open-menu registry') -----
+ registeredOpenCommands
+ "Answer the list of dynamic open commands, sorted by description"
+
+ ^self registry asArray sort: [ :a :b | a first asLowercase < b first asLowercase ]!
Item was added:
+ ----- Method: TheWorldMenu class>>registry (in category 'open-menu registry') -----
+ registry
+ "Answer the registry of dynamic open commands"
+
+ ^OpenMenuRegistry ifNil: [OpenMenuRegistry := OrderedCollection new].
+ !
Item was added:
+ ----- Method: TheWorldMenu class>>removeObsolete (in category 'open-menu registry') -----
+ removeObsolete
+ "Remove all obsolete commands"
+ self registry removeAllSuchThat: [:e | e second first class isObsolete].!
Item was added:
+ ----- Method: TheWorldMenu class>>unregisterOpenCommand: (in category 'open-menu registry') -----
+ unregisterOpenCommand: label
+ "Remove the open command with the given label from the registry"
+
+ self registry removeAllSuchThat: [:e | e first = label]!
Item was added:
+ ----- Method: TheWorldMenu class>>unregisterOpenCommandWithReceiver: (in category 'open-menu registry') -----
+ unregisterOpenCommandWithReceiver: aReceiver
+ "Remove the open command with the given object as receiver from the registry"
+
+ self registry removeAllSuchThat: [:e | e second first == aReceiver]!
Item was added:
+ ----- Method: TheWorldMenu>>addGestureHelpItemsTo: (in category 'menu') -----
+ addGestureHelpItemsTo: aMenuMorph
+ !
Item was added:
+ ----- Method: TheWorldMenu>>addObjectsAndTools: (in category 'construction') -----
+ addObjectsAndTools: menu
+ self
+ fillIn: menu
+ from: {
+ nil.
+ { 'objects (o)'. { #myWorld. #activateObjectsTool }. 'A tool for finding and obtaining many kinds of objects' }.
+ { 'new morph...'. { self. #newMorph }. 'Offers a variety of ways to create new objects' }.
+ nil.
+ { 'authoring tools...'. { self. #scriptingDo }. 'A menu of choices useful for authoring' }.
+ { 'playfield options...'. { self. #playfieldDo }. 'A menu of options pertaining to this object as viewed as a playfield' }.
+ { 'flaps...'. { self. #flapsDo }. 'A menu relating to use of flaps. For best results, use "keep this menu up"' }.
+ { 'projects...'. { self. #projectDo }. 'A menu of commands relating to use of projects' }.
+ { 'telemorphic...' . {self. #remoteDo}. 'commands for doing multi-machine "telemorphic" experiments'}.
+ nil
+ }!
Item was added:
+ ----- Method: TheWorldMenu>>addPrintAndDebug: (in category 'construction') -----
+ addPrintAndDebug: menu
+ Preferences simpleMenus ifFalse: [
+ self
+ fillIn: menu
+ from: {
+ { 'make screenshot'. {self. #saveScreenshot}. 'makes a screenshot and saves it to disk'}.
+ "{ 'print PS to file...'. { self. #printWorldOnFile }. 'write the world into a postscript file' }."
+ { 'debug...'. { self. #debugDo }. 'a menu of debugging items' }
+ } ]!
Item was added:
+ ----- Method: TheWorldMenu>>addProjectEntries: (in category 'construction') -----
+ addProjectEntries: menu
+ self
+ fillIn: menu
+ from: {
+ nil.
+ { 'previous project'. { #myWorld. #goBack }. 'return to the most-recently-visited project' }.
+ { 'jump to project...'. { #myWorld. #jumpToProject }. 'put up a list of all projects, letting me choose one to go to' }.
+ { 'save project on file...'. { #myWorld. #saveOnFile }. 'save this project on a file' }.
+ {'load project from file...'. {self. #loadProject}. 'load a project from a file' }.
+ nil
+ }!
Item was added:
+ ----- Method: TheWorldMenu>>addRestoreDisplay: (in category 'construction') -----
+ addRestoreDisplay: menu
+ self
+ fillIn: menu
+ from: {
+ {'restore display (r)'. { World. #restoreMorphicDisplay }. 'repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.' }.
+ nil
+ }!
Item was added:
+ ----- Method: TheWorldMenu>>addSaveAndQuit: (in category 'construction') -----
+ addSaveAndQuit: menu
+ self
+ fillIn: menu
+ from: {
+ nil.
+ { 'save'. { Smalltalk. #saveSession }. 'save the current version of the image on disk' }.
+ { 'save as...'. { Smalltalk. #saveAs }. 'save the current version of the image on disk under a new name.' }.
+ { 'save as new version'. { Smalltalk. #saveAsNewVersion }. 'give the current image a new version-stamped name and save it under that name on disk.' }.
+ { 'save and quit'. { self. #saveAndQuit }. 'save the current image on disk, and quit out of Squeak.' }.
+ { 'quit'. { self. #quitSession }. 'quit out of Squeak.' }
+ }!
Item was added:
+ ----- Method: TheWorldMenu>>addUtilities: (in category 'construction') -----
+ addUtilities: menu
+ Preferences simpleMenus ifFalse: [
+ self
+ fillIn: menu
+ from: {
+ { 'open...'. { self. #openWindow } }.
+ { 'windows...'. { self. #windowsDo } }.
+ { 'changes...'. { self. #changesDo } }
+ } ].
+ self
+ fillIn: menu
+ from: {
+ { 'help...'. { self. #helpDo }. 'puts up a menu of useful items for updating the system, determining what version you are running, and much else' }.
+ { 'appearance...'. { self. #appearanceDo }. 'put up a menu offering many controls over appearance.' }
+ }.
+ Preferences simpleMenus ifFalse: [
+ self
+ fillIn: menu
+ from: {
+ { 'do...'. { Utilities. #offerCommonRequests }. 'put up an editible list of convenient expressions, and evaluate the one selected.' }
+ } ]!
Item was added:
+ ----- Method: TheWorldMenu>>alphabeticalMorphMenu (in category 'construction') -----
+ alphabeticalMorphMenu
+ | list splitLists menu firstChar lastChar subMenu |
+ list := Morph withAllSubclasses select: [:m | m includeInNewMorphMenu].
+ list := list asArray sortBy: [:c1 :c2 | c1 name < c2 name].
+ splitLists := self splitNewMorphList: list depth: 3.
+ menu := MenuMorph new defaultTarget: self.
+ 1 to: splitLists size
+ do:
+ [:i |
+ firstChar := i = 1
+ ifTrue: [$A]
+ ifFalse:
+ [((splitLists at: i - 1) last name first asInteger + 1)
+ asCharacter].
+ lastChar := i = splitLists size
+ ifTrue: [$Z]
+ ifFalse: [(splitLists at: i) last name first].
+ subMenu := MenuMorph new.
+ (splitLists at: i) do:
+ [:cl |
+ subMenu
+ add: cl name
+ target: self
+ selector: #newMorphOfClass:event:
+ argument: cl].
+ menu add: firstChar asString , ' - ' , lastChar asString subMenu: subMenu].
+ ^menu!
Item was added:
+ ----- Method: TheWorldMenu>>appearanceDo (in category 'popups') -----
+ appearanceDo
+ "Build and show the appearance menu for the world."
+
+ self doPopUp: self appearanceMenu!
Item was added:
+ ----- Method: TheWorldMenu>>appearanceMenu (in category 'construction') -----
+ appearanceMenu
+ "Build the appearance menu for the world."
+
+ ^self fillIn: (self menu: 'appearance...') from: {
+
+ {'preferences...' . { self . #openPreferencesBrowser} . 'Opens a "Preferences Browser" which allows you to alter many settings' } .
+ {'choose theme...' . { Preferences . #offerThemesMenu} . 'Presents you with a menu of themes; each item''s balloon-help will tell you about the theme. If you choose a theme, many different preferences that come along with that theme are set at the same time; you can subsequently change any settings by using a Preferences Panel'} .
+ nil .
+ {'system fonts...' . { self . #standardFontDo} . 'Choose the standard fonts to use for code, lists, menus, window titles, etc.'}.
+ {'text highlight color...' . { Preferences . #chooseTextHighlightColor} . 'Choose which color should be used for text highlighting in Morphic.'}.
+ {'insertion point color...' . { Preferences . #chooseInsertionPointColor} . 'Choose which color to use for the text insertion point in Morphic.'}.
+ {'keyboard focus color' . { Preferences . #chooseKeyboardFocusColor} . 'Choose which color to use for highlighting which pane has the keyboard focus'}.
+ nil.
+ {#menuColorString . { Preferences . #toggleMenuColorPolicy} . 'Governs whether menu colors should be derived from the desktop color.'}.
+ {#roundedCornersString . { Preferences . #toggleRoundedCorners} . 'Governs whether morphic windows and menus should have rounded corners.'}.
+ nil.
+ {'full screen on' . { Project current . #fullScreenOn} . 'puts you in full-screen mode, if not already there.'}.
+ {'full screen off' . { Project current . #fullScreenOff} . 'if in full-screen mode, takes you out of it.'}.
+ nil.
+ {'set display depth...' . {self. #setDisplayDepth} . 'choose how many bits per pixel.'}.
+ {'set desktop color...' . {self. #changeBackgroundColor} . 'choose a uniform color to use as desktop background.'}.
+ {'set gradient color...' . {self. #setGradientColor} . 'choose second color to use as gradient for desktop background.'}.
+ {'use texture background' . { #myWorld . #setStandardTexture} . 'apply a graph-paper-like texture background to the desktop.'}.
+ nil.
+ {'clear turtle trails from desktop' . { #myWorld . #clearTurtleTrails} . 'remove any pigment laid down on the desktop by objects moving with their pens down.'}.
+ {'pen-trail arrowhead size...' . { Preferences. #setArrowheads} . 'choose the shape to be used in arrowheads on pen trails.'}.
+
+ }!
Item was added:
+ ----- Method: TheWorldMenu>>buildWorldMenu (in category 'construction') -----
+ buildWorldMenu
+ "Build the menu that is put up when the screen-desktop is clicked on"
+ | menu |
+ menu := MenuMorph new defaultTarget: self.
+ menu commandKeyHandler: self.
+ self colorForDebugging: menu.
+ menu addStayUpItem.
+ self makeConvenient: menu.
+ Smalltalk at: #ServiceGUI ifPresent:[:sgui|
+ sgui worldMenu: menu.
+ sgui onlyServices ifTrue: [^ menu].
+ ].
+ self addProjectEntries: menu.
+ myWorld addUndoItemsTo: menu.
+ self addRestoreDisplay: menu.
+ self addUtilities: menu.
+ self addObjectsAndTools: menu.
+ self addPrintAndDebug: menu.
+ self addSaveAndQuit: menu.
+ ^ menu!
Item was added:
+ ----- Method: TheWorldMenu>>changeBackgroundColor (in category 'commands') -----
+ changeBackgroundColor
+ "Let the user select a new background color for the world"
+ myWorld
+ changeColorTarget: myWorld
+ selector: #color:
+ originalColor: myWorld color asColor
+ hand: myWorld activeHand!
Item was added:
+ ----- Method: TheWorldMenu>>changesDo (in category 'popups') -----
+ changesDo
+ "Build the changes menu for the world."
+
+ self doPopUp: self changesMenu!
Item was added:
+ ----- Method: TheWorldMenu>>changesMenu (in category 'construction') -----
+ changesMenu
+ "Build the changes menu for the world."
+
+ | menu |
+ menu := self menu: 'changes...'.
+ self fillIn: menu from: {
+ { 'file out current change set' . { ChangeSet current . #verboseFileOut}.
+ 'Write the current change set out to a file whose name reflects the change set name and the current date & time.'}.
+ { 'create new change set...' . { ChangeSet . #newChangeSet}. 'Create a new change set and make it the current one.'}.
+ { 'browse changed methods' . { ChangeSet . #browseChangedMessages}. 'Open a message-list browser showing all methods in the current change set'}.
+ { 'check change set for slips' . { self . #lookForSlips}.
+ 'Check the current change set for halts, references to the Transcript, etc., and if any such thing is found, open up a message-list browser detailing all possible slips.'}.
+
+ nil.
+ { 'simple change sorter' . {self. #openChangeSorter1}. 'Open a 3-paned changed-set viewing tool'}.
+ { 'dual change sorter' . {self. #openChangeSorter2}.
+ 'Open a change sorter that shows you two change sets at a time, making it easy to copy and move methods and classes between them.'}.
+ { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}.
+ nil.
+ { 'browse recent submissions (R)' . { Utilities . #browseRecentSubmissions}.
+ 'Open a new recent-submissions browser. A recent-submissions browser is a message-list browser that shows the most recent methods that have been submitted. If you submit changes within that browser, it will keep up-to-date, always showing the most recent submissions.'}.
+ { 'browse my changes' . { SystemNavigation new . #browseMyChanges }.
+ 'Browse all of my changes since the last time #condenseSources was run.'}.
+ nil.
+ { 'recently logged changes...' . { self . #browseRecentLog}.'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'}.
+
+ { 'recent log file...' . { Smalltalk . #writeRecentToFile}.
+ 'Create a file holding the logged changes (going as far back as you wish), and open a window on that file.'}.
+
+ nil.
+ { 'save world as morph file' . {self. #saveWorldInFile}. 'Save a file that, when reloaded, reconstitutes the current World.'}.
+ nil.
+ }.
+ ^ menu!
Item was added:
+ ----- Method: TheWorldMenu>>cleanUpWorld (in category 'commands') -----
+ cleanUpWorld
+ (UIManager default confirm:
+ 'This will remove all windows except those
+ containing unsubmitted text edits, and will
+ also remove all non-window morphs (other
+ than flaps) found on the desktop. Are you
+ sure you want to do this?' translated)
+ ifFalse: [^ self].
+
+ myWorld allNonFlapRelatedSubmorphs do:
+ [:m | m delete].
+ (SystemWindow windowsIn: myWorld satisfying: [:w | w model canDiscardEdits])
+ do: [:w | w delete]!
Item was added:
+ ----- Method: TheWorldMenu>>colorForDebugging: (in category 'construction') -----
+ colorForDebugging: aMenu
+
+ "aMenu color: self myMenuColor"
+
+ "aMenu color: Color lightRed"
+
+ !
Item was added:
+ ----- Method: TheWorldMenu>>commandKeyTypedIntoMenu: (in category 'action') -----
+ commandKeyTypedIntoMenu: evt
+ "The user typed a command-key into the given menu; dispatch it"
+
+ myWorld keystrokeInWorld: evt !
Item was added:
+ ----- Method: TheWorldMenu>>debugDo (in category 'popups') -----
+ debugDo
+
+ self doPopUp: self debugMenu!
Item was added:
+ ----- Method: TheWorldMenu>>debugMenu (in category 'construction') -----
+ debugMenu
+
+ | menu |
+
+ menu := self menu: 'debug...'.
+ self fillIn: menu from: {
+ { 'inspect world' . { #myWorld . #inspect } }.
+ { 'explore world' . { #myWorld . #explore } }.
+ { 'inspect model' . { self . #inspectWorldModel } }.
+ " { 'talk to world...' . { self . #typeInMessageToWorld } }."
+ { 'start MessageTally' . { self . #startMessageTally } }.
+ { 'start/browse MessageTally' . { self . #startThenBrowseMessageTally } }.
+ { 'open process browser' . { self . #openProcessBrowser } }.
+ nil.
+ "(self hasProperty: #errorOnDraw) ifTrue: Later make this come up only when needed."
+ { 'start drawing again' . { #myWorld . #resumeAfterDrawError } }.
+ { 'start stepping again' . { #myWorld . #resumeAfterStepError } }.
+ nil.
+ { 'call #tempCommand' . { #myWorld . #tempCommand } }.
+ { 'define #tempCommand' . { #myWorld . #defineTempCommand } }.
+ }.
+ self haltOnceEnabled
+ ifTrue: [menu
+ add: 'disable halt/inspect once' translated
+ target: menu
+ action: #clearHaltOnce]
+ ifFalse: [menu
+ add: 'enable halt/inspect once' translated
+ target: menu
+ action: #setHaltOnce].
+ ^menu
+ !
Item was added:
+ ----- Method: TheWorldMenu>>doMenuItem:with: (in category 'action') -----
+ doMenuItem: aCollection with: event
+ | realTarget selector nArgs |
+ selector := aCollection second.
+ nArgs := selector numArgs.
+ realTarget := aCollection first.
+ realTarget == #myWorld ifTrue: [realTarget := myWorld].
+ realTarget == #myHand ifTrue: [realTarget := myHand].
+ realTarget == #myProject ifTrue: [realTarget := self projectForMyWorld].
+ ^nArgs = 0
+ ifTrue:[realTarget perform: selector]
+ ifFalse:[realTarget perform: selector with: event].
+ !
Item was added:
+ ----- Method: TheWorldMenu>>doPopUp: (in category 'popups') -----
+ doPopUp: aMenu
+
+ aMenu popUpForHand: myHand in: myWorld.
+ !
Item was added:
+ ----- Method: TheWorldMenu>>fillIn:from: (in category 'construction') -----
+ fillIn: aMenu from: dataForMenu
+ "A menu constructor utility by RAA. dataForMenu is a list of items which mean:
+ nil Indicates to add a line
+
+ first element is symbol Add updating item with the symbol as the wording selector
+ second element is a list second element has the receiver and selector
+
+ first element is a string Add menu item with the string as its wording
+ second element is a list second element has the receiver and selector
+
+ a third element exists Use it as the balloon text
+ a fourth element exists Use it as the enablement selector (updating case only)"
+
+
+ dataForMenu do: [ :itemData | | item |
+ itemData ifNil: [aMenu addLine] ifNotNil:
+ [item := (itemData first isKindOf: Symbol)
+ ifTrue:
+ [aMenu
+ addUpdating: itemData first
+ target: self
+ selector: #doMenuItem:with:
+ argumentList: {itemData second}]
+ ifFalse:
+ [aMenu
+ add: itemData first translated
+ target: self
+ selector: #doMenuItem:with:
+ argumentList: {itemData second}].
+ itemData size >= 3 ifTrue:
+ [aMenu balloonTextForLastItem: itemData third translated.
+ itemData size >= 4 ifTrue:
+ [item enablementSelector: itemData fourth]]]].
+
+ ^ aMenu!
Item was added:
+ ----- Method: TheWorldMenu>>garbageCollect (in category 'commands') -----
+ garbageCollect
+ "Do a garbage collection, and report results to the user."
+
+ Utilities garbageCollectAndReport!
Item was added:
+ ----- Method: TheWorldMenu>>helpDo (in category 'popups') -----
+ helpDo
+ "Build and show the help menu for the world."
+
+ self doPopUp: self helpMenu!
Item was added:
+ ----- Method: TheWorldMenu>>helpMenu (in category 'construction') -----
+ helpMenu
+ "Build the help menu for the world."
+ | menu |
+
+ menu := self menu: 'help...'.
+
+ self fillIn: menu from:
+ {
+ {'about this system...'. {Smalltalk. #aboutThisSystem}. 'current version information.'}.
+ {'update code from server'. {MCMcmUpdater. #updateFromServer}. 'load latest code updates via the internet'}.
+ {'preferences...'. {self. #openPreferencesBrowser}. 'view and change various options.'}.
+ {'set language...' . {Project. #chooseNaturalLanguage}. 'choose the language in which tiles should be displayed.'} .
+ nil.
+ {'command-key help'. { Utilities . #openCommandKeyHelp}. 'summary of keyboard shortcuts.'}
+ }.
+
+ self addGestureHelpItemsTo: menu.
+
+ self fillIn: menu from:
+ {
+ {'world menu help'. { self . #worldMenuHelp}. 'helps find menu items buried in submenus.'}.
+ "{'info about flaps' . { Utilities . #explainFlaps}. 'describes how to enable and use flaps.'}."
+ {'font size summary' . { TextStyle . #fontSizeSummary}. 'summary of names and sizes of available fonts.'}.
+ {'useful expressions' . { Utilities . #openStandardWorkspace}. 'a window full of useful expressions.'}.
+ {'annotation setup...' . { Preferences . #editAnnotations}. 'Click here to get a little window that will allow you to specify which types of annotations, in which order, you wish to see in the annotation panes of browsers and other tools'}.
+ nil.
+ {'graphical imports' . { Imports default . #viewImages}. 'view the global repository called ImageImports; you can easily import external graphics into ImageImports via the FileList'}.
+ {'standard graphics library' . { ScriptingSystem . #inspectFormDictionary}. 'lets you view and change the system''s standard library of graphics.'}.
+ nil.
+ {'telemorphic...' . {self. #remoteDo}. 'commands for doing multi-machine "telemorphic" experiments'}.
+ {#soundEnablingString . { SoundService . #toggleSoundEnabled}. 'turning sound off will completely disable Squeak''s use of sound.'}.
+ nil.
+
+ {'set author initials...' . { Utilities . #setAuthorInitials }. 'supply initials to be used to identify the author of code and other content.'}.
+ {'vm statistics' . { self . #vmStatistics}. 'obtain some intriguing data about the vm.'}.
+ nil.
+ {'purge undo records' . { CommandHistory . #resetAllHistory }. 'save space by removing all the undo information remembered in all projects.'}.
+ {'space left' . { self . #garbageCollect}. 'perform a full garbage-collection and report how many bytes of space remain in the image.'}.
+ }.
+
+ ^menu
+
+ !
Item was added:
+ ----- Method: TheWorldMenu>>loadProject (in category 'commands') -----
+ loadProject
+
+ | stdFileMenuResult path |
+ "Put up a Menu and let the user choose a '.project' file to load. Create a thumbnail and jump into the project."
+
+ Project canWeLoadAProjectNow ifFalse: [^ self].
+ path := FileList2 modalFolderSelector.
+ path ifNil: [^ nil].
+ stdFileMenuResult := ((StandardFileMenu new) pattern: '*.pr';
+ oldFileFrom: path)
+ startUpWithCaption: 'Select a File:' translated.
+ stdFileMenuResult ifNil: [^ nil].
+ ProjectLoading
+ openFromDirectory: stdFileMenuResult directory
+ andFileName: stdFileMenuResult name
+ !
Item was added:
+ ----- Method: TheWorldMenu>>lookForSlips (in category 'commands') -----
+ lookForSlips
+
+ ChangeSet current lookForSlips!
Item was added:
+ ----- Method: TheWorldMenu>>makeConvenient: (in category 'construction') -----
+ makeConvenient: menu
+ self
+ fillIn: menu
+ from: {
+ { 'Browser'. { StandardToolSet. #openClassBrowser }. 'open a browser' }.
+ { 'Workspace'. { Workspace. #open }. 'open a workspace' }.
+ { 'Transcript'. { Transcript. #open }. 'open a transcript' }.
+ Smalltalk at: #TestRunner ifPresent:[:aClass|
+ { 'Test Runner'. { aClass. #open }. 'open a test runner' }.
+ ].
+ nil
+ }!
Item was added:
+ ----- Method: TheWorldMenu>>menu: (in category 'mechanics') -----
+ menu: titleString
+ "Create a menu with the given title, ready for filling"
+
+ | menu |
+ (menu := MenuMorph entitled: titleString translated)
+ defaultTarget: self;
+ addStayUpItem;
+ commandKeyHandler: self.
+ self colorForDebugging: menu.
+ ^ menu
+ !
Item was added:
+ ----- Method: TheWorldMenu>>menuColorString (in category 'action') -----
+ menuColorString
+
+ ^ Preferences menuColorString!
Item was added:
+ ----- Method: TheWorldMenu>>mvcProjectsAllowed (in category 'commands') -----
+ mvcProjectsAllowed
+
+ ^Preferences mvcProjectsAllowed and: [Smalltalk includesKey: #StandardSystemView]!
Item was added:
+ ----- Method: TheWorldMenu>>newMorph (in category 'construction') -----
+ newMorph
+ "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs."
+
+ | menu |
+
+ menu := self menu: 'Add a new morph'.
+ menu
+ add: 'from paste buffer' translated target: myHand action: #pasteMorph;
+ add: 'from alphabetical list' translated subMenu: self alphabeticalMorphMenu;
+ add: 'from a file...' translated target: self action: #readMorphFromAFile.
+ menu addLine.
+ menu add: 'grab rectangle from screen' translated target: myWorld action: #grabDrawingFromScreen:;
+ add: 'grab with lasso from screen' translated target: myWorld action: #grabLassoFromScreen:;
+ add: 'grab rubber band from screen' translated target: myWorld action: #grabRubberBandFromScreen:;
+ add: 'grab flood area from screen' translated target: myWorld action: #grabFloodFromScreen:.
+ menu addLine.
+ menu add: 'make new drawing' translated target: myWorld action: #newDrawingFromMenu:;
+ add: 'make link to project...' translated target: self action: #projectThumbnail.
+
+ self doPopUp: menu.
+ !
Item was added:
+ ----- Method: TheWorldMenu>>newMorphOfClass:event: (in category 'commands') -----
+ newMorphOfClass: morphClass event: evt
+ "Attach a new morph of the given class to the invoking hand."
+
+ | m |
+ m := morphClass new.
+ m installModelIn: myWorld. "a chance to install model pointers"
+ m wantsToBeOpenedInWorld
+ ifTrue:[myWorld addMorph: m]
+ ifFalse:[evt hand attachMorph: m].
+ myWorld startSteppingSubmorphsOf: m.
+ !
Item was added:
+ ----- Method: TheWorldMenu>>openBrowser (in category 'commands') -----
+ openBrowser
+ "Create and schedule a Browser view for browsing code."
+ ToolSet browse: nil selector: nil!
Item was added:
+ ----- Method: TheWorldMenu>>openFileDirectly (in category 'commands') -----
+ openFileDirectly
+
+ FileList openFileDirectly!
Item was added:
+ ----- Method: TheWorldMenu>>openFileList (in category 'commands') -----
+ openFileList
+ FileList open.!
Item was added:
+ ----- Method: TheWorldMenu>>openMVCProject (in category 'commands') -----
+ openMVCProject
+ "Open a new MVC project (only if MVC is present)"
+ Smalltalk at: #MVCProject ifPresent:[:projClass|
+ ProjectViewMorph openOn: projClass new.
+ ].!
Item was added:
+ ----- Method: TheWorldMenu>>openMenu (in category 'construction') -----
+ openMenu
+ "Build the open window menu for the world."
+
+ | menu |
+ menu := self menu: 'open...'.
+ menu defaultTarget: ToolSet default.
+ menu addList: ToolSet menuItems.
+ menu defaultTarget: self.
+ self fillIn: menu from: {
+ nil.
+ {'file...' . { self . #openFileDirectly} . 'Lets you open a window on a single file'}.
+ {'transcript (t)' . {self . #openTranscript}. 'A window used to report messages sent to Transcript' }.
+ "{'inner world' . { WorldWindow . #test1} }."
+ nil.
+ }.
+ self fillIn: menu from: self class registeredOpenCommands.
+ menu addLine.
+
+ self mvcProjectsAllowed ifTrue:
+ [self fillIn: menu from: { {'mvc project' . {self. #openMVCProject} . 'Creates a new project of the classic "mvc" style'} }].
+
+ self fillIn: menu from: {
+ {'morphic project' . {self. #openMorphicProject} . 'Creates a new morphic project'}.
+ }.
+ Smalltalk at: #SMxMorphicProject ifPresent: [:p |
+ self fillIn: menu from: {
+ { 'simple morphic project' . { self . #openSMxMorphicProject } . 'Creates a new simple morphic project' }.
+ }
+ ].
+ ^menu
+ !
Item was added:
+ ----- Method: TheWorldMenu>>openMorphicProject (in category 'commands') -----
+ openMorphicProject
+ "Open a morphic project from within a morphic project"
+ MorphicProject openViewOn: nil
+ !
Item was added:
+ ----- Method: TheWorldMenu>>openPreferencesBrowser (in category 'commands') -----
+ openPreferencesBrowser
+ "Open a preferences browser"
+ ^Smalltalk at: #PreferenceBrowser ifPresent:[:pb| pb open].
+ !
Item was added:
+ ----- Method: TheWorldMenu>>openTranscript (in category 'commands') -----
+ openTranscript
+
+ Transcript openLabel: 'Transcript'!
Item was added:
+ ----- Method: TheWorldMenu>>openWindow (in category 'popups') -----
+ openWindow
+
+ self doPopUp: self openMenu!
Item was added:
+ ----- Method: TheWorldMenu>>openWorkspace (in category 'commands') -----
+ openWorkspace
+
+ UIManager default edit: '' label: 'Workspace'!
Item was added:
+ ----- Method: TheWorldMenu>>projectDo (in category 'popups') -----
+ projectDo
+ "Build and show the project menu for the world."
+
+ self doPopUp: self projectMenu!
Item was added:
+ ----- Method: TheWorldMenu>>projectForMyWorld (in category 'commands') -----
+ projectForMyWorld
+
+ ^myProject ifNil: [myProject := myWorld project]!
Item was added:
+ ----- Method: TheWorldMenu>>projectMenu (in category 'construction') -----
+ projectMenu
+ "Build the project menu for the world."
+ | menu |
+
+ self flag: #bob0302.
+
+ menu := self menu: 'projects...'.
+ self fillIn: menu from: {
+ { 'save on server (also makes a local copy)' . { #myProject . #storeOnServer } }.
+ { 'save to a different server' . { #myProject . #saveAs } }.
+ { 'save project on local file only' . { #myWorld . #saveOnFile } }.
+ { 'see if server version is more recent...' . { #myProject . #loadFromServer } }.
+ { 'load project from file...' . { self . #loadProject } }.
+ nil.
+ }.
+
+ self mvcProjectsAllowed ifTrue: [
+ self fillIn: menu from: {
+ { 'create new mvc project'. { self . #openMVCProject } }.
+ }
+ ].
+ self fillIn: menu from: {
+ { 'create new morphic project' . { self . #openMorphicProject } }.
+ }.
+ Smalltalk at: #SMxMorphicProject ifPresent: [:p |
+ self fillIn: menu from: {
+ { 'create new simple morphic project' . { self . #openSMxMorphicProject } }.
+ }
+ ].
+ self fillIn: menu from: {
+ nil.
+ { 'go to previous project' . { Project . #returnToPreviousProject } }.
+ { 'go to next project' . { Project . #advanceToNextProject } }.
+ { 'jump to project...' . { #myWorld . #jumpToProject } }.
+ }.
+ Preferences simpleMenus ifFalse: [
+ self fillIn: menu from: {
+ nil.
+ { 'save for future revert' . { #myProject . #saveForRevert } }.
+ { 'revert to saved copy' . { #myProject . #revert } }.
+ }.
+ ].
+
+ ^ menu!
Item was added:
+ ----- Method: TheWorldMenu>>projectThumbnail (in category 'action') -----
+ projectThumbnail
+ "Offer the user a menu of project names. Attach to the hand a thumbnail of the project the user selects."
+
+ | projName pr names values |
+ names := OrderedCollection with: Project current name, ' (current)'.
+ values := OrderedCollection with: Project current name.
+ Project allNames do: [:n | names add: n. values add: n].
+ projName := UIManager default
+ chooseFrom: names values: values lines: #(1) title: 'Select a project'.
+ projName ifNotNil:
+ [(pr := Project named: projName)
+ ifNotNil: [myHand attachMorph: (ProjectViewMorph on: pr)]
+ ifNil: [self inform: 'can''t seem to find that project']].!
Item was added:
+ ----- Method: TheWorldMenu>>quitSession (in category 'commands') -----
+ quitSession
+
+ Smalltalk
+ snapshot: (UserDialogBoxMorph
+ confirm: 'Save changes before quitting?' translated
+ orCancel: [^ self]
+ at: World center)
+ andQuit: true!
Item was added:
+ ----- Method: TheWorldMenu>>readMorphFromAFile (in category 'commands') -----
+ readMorphFromAFile
+ "Produce a morph from a file -- either a saved .morph file or a graphics file"
+
+ | morphOrList ff aName f m |
+ aName := Utilities chooseFileWithSuffixFromList:
+ (#('.morph'), Utilities graphicsFileSuffixes) withCaption: 'Choose a file
+ to load' translated.
+ aName ifNil: [^ self]. "User made no choice"
+ aName == #none ifTrue: [^ self inform:
+ 'Sorry, no suitable files found
+ (names should end with .morph, .gif,
+ .bmp, .jpeg, .jpe, .jp, or .form)' translated].
+
+ (aName asLowercase endsWith: '.morph')
+ ifTrue:
+ [ff := FileStream readOnlyFileNamed: aName.
+ morphOrList := ff fileInObjectAndCode. "code filed in is the Model class"
+ "the file may contain either a single morph or an array of morphs"
+ myWorld addMorphsAndModel: morphOrList]
+ ifFalse:
+ [f := Form fromFileNamed: aName.
+ f ifNil: [^ self error: 'unrecognized image file format' translated].
+ m := myWorld drawingClass new form: f.
+ myHand attachMorph: m]
+ !
Item was added:
+ ----- Method: TheWorldMenu>>remoteDo (in category 'popups') -----
+ remoteDo
+
+ self doPopUp: self remoteMenu!
Item was added:
+ ----- Method: TheWorldMenu>>remoteMenu (in category 'construction') -----
+ remoteMenu
+ "Build the Telemorphic menu for the world."
+
+ ^self fillIn: (self menu: 'Telemorphic') from: {
+ { 'local host address' . { #myWorld . #reportLocalAddress } }.
+ { 'connect remote user' . { #myWorld . #connectRemoteUser } }.
+ { 'disconnect remote user' . { #myWorld . #disconnectRemoteUser } }.
+ { 'disconnect all remote users' . { #myWorld . #disconnectAllRemoteUsers } }.
+ }!
Item was added:
+ ----- Method: TheWorldMenu>>roundedCornersString (in category 'action') -----
+ roundedCornersString
+
+ ^ Preferences roundedCornersString!
Item was added:
+ ----- Method: TheWorldMenu>>saveAndQuit (in category 'commands') -----
+ saveAndQuit
+
+ Smalltalk snapshot: true andQuit: true!
Item was added:
+ ----- Method: TheWorldMenu>>saveScreenshot (in category 'action') -----
+ saveScreenshot
+ "Make a screenshot of the world and save it to a file"
+
+ SampledSound playSoundNamed: 'camera'.
+ PNGReadWriter putForm: myWorld imageForm onFileNamed:
+ (FileDirectory default nextNameFor: 'SqueakScreen' extension:'png').
+ !
Item was added:
+ ----- Method: TheWorldMenu>>saveWorldInFile (in category 'commands') -----
+ saveWorldInFile
+ "Save the world's submorphs, model, and stepList in a file. "
+
+ | fileName fileStream aClass |
+ fileName := UIManager default request: 'File name for this morph?'.
+ fileName isEmpty ifTrue: [^ self]. "abort"
+
+ "Save only model, stepList, submorphs in this world"
+ myWorld submorphsDo: [:m |
+ m allMorphsDo: [:subM | subM prepareToBeSaved]]. "Amen"
+
+ fileStream := FileStream newFileNamed: fileName, '.morph'.
+ aClass := myWorld model ifNil: [nil] ifNotNil: [myWorld model class].
+ fileStream fileOutClass: aClass andObject: myWorld.
+ !
Item was added:
+ ----- Method: TheWorldMenu>>setDisplayDepth (in category 'commands') -----
+ setDisplayDepth
+ "Let the user choose a new depth for the display. "
+
+ | result oldDepth allDepths allLabels hasBoth |
+ oldDepth := Display nativeDepth.
+ allDepths := #(1 -1 2 -2 4 -4 8 -8 16 -16 32 -32) select: [:d | Display supportsDisplayDepth: d].
+ hasBoth := (allDepths anySatisfy:[:d| d > 0]) and:[allDepths anySatisfy:[:d| d < 0]].
+ allLabels := allDepths collect:[:d|
+ String streamContents:[:s|
+ s nextPutAll: (d = oldDepth ifTrue:['<on>'] ifFalse:['<off>']).
+ s print: d abs.
+ hasBoth ifTrue:[s nextPutAll: (d > 0 ifTrue:[' (big endian)'] ifFalse:[' (little endian)'])].
+ ]].
+ result := UIManager default
+ chooseFrom: allLabels
+ values: allDepths
+ title: 'Choose a display depth' translated.
+ result ifNotNil: [Display newDepth: result].
+ oldDepth := oldDepth abs.
+ (Smalltalk isMorphic and: [(Display depth < 4) ~= (oldDepth < 4)])
+ ifTrue:
+ ["Repaint windows since they look better all white in depth < 4"
+ (SystemWindow windowsIn: myWorld satisfying: [:w | true]) do:
+ [:w |
+ oldDepth < 4
+ ifTrue: [w restoreDefaultPaneColor]
+ ifFalse: [w updatePaneColors]]]!
Item was added:
+ ----- Method: TheWorldMenu>>setGradientColor (in category 'action') -----
+ setGradientColor
+
+ myWorld setGradientColor: myHand lastEvent!
Item was added:
+ ----- Method: TheWorldMenu>>soundEnablingString (in category 'action') -----
+ soundEnablingString
+
+ ^ SoundService soundEnablingString!
Item was added:
+ ----- Method: TheWorldMenu>>splitNewMorphList:depth: (in category 'commands') -----
+ splitNewMorphList: list depth: d
+ | middle c prev next out |
+ d <= 0 ifTrue: [^Array with: list].
+ middle := list size // 2 + 1.
+ c := (list at: middle) name first.
+ prev := middle - 1.
+ [prev > 0 and: [(list at: prev) name first = c]]
+ whileTrue: [prev := prev - 1].
+ next := middle + 1.
+ [next <= list size and: [(list at: next) name first = c]]
+ whileTrue: [next := next + 1].
+ "Choose the better cluster"
+ middle := middle - prev < (next - middle)
+ ifTrue: [prev + 1]
+ ifFalse: [next].
+ middle = 1 ifTrue: [middle := next].
+ middle >= list size ifTrue: [middle := prev + 1].
+ (middle = 1 or: [middle >= list size]) ifTrue: [^Array with: list].
+ out := WriteStream on: Array new.
+ out nextPutAll: (self splitNewMorphList: (list copyFrom: 1 to: middle - 1)
+ depth: d - 1).
+ out
+ nextPutAll: (self splitNewMorphList: (list copyFrom: middle to: list size)
+ depth: d - 1).
+ ^out contents!
Item was added:
+ ----- Method: TheWorldMenu>>staggerPolicyString (in category 'action') -----
+ staggerPolicyString
+
+ ^ Preferences staggerPolicyString!
Item was added:
+ ----- Method: TheWorldMenu>>standardFontDo (in category 'popups') -----
+ standardFontDo
+ "Build and show the standard font menu"
+
+ self doPopUp: Preferences fontConfigurationMenu!
Item was added:
+ ----- Method: TheWorldMenu>>startMessageTally (in category 'commands') -----
+ startMessageTally
+
+ (self confirm: 'MessageTally will start now,
+ and stop when the cursor goes
+ to the top of the screen') ifTrue:
+ [MessageTally spyOn:
+ [[Sensor peekMousePt y > 0] whileTrue: [World doOneCycle]]]!
Item was added:
+ ----- Method: TheWorldMenu>>suppressFlapsString (in category 'windows & flaps menu') -----
+ suppressFlapsString
+ "Answer the wording of the suppress-flaps item"
+
+ ^ Project current suppressFlapsString!
Item was added:
+ ----- Method: TheWorldMenu>>toggleWindowPolicy (in category 'action') -----
+ toggleWindowPolicy
+
+ Preferences toggleWindowPolicy!
Item was added:
+ ----- Method: TheWorldMenu>>vmStatistics (in category 'commands') -----
+ vmStatistics
+ "Open a string view on a report of vm statistics"
+
+ (StringHolder new contents: Smalltalk vmStatisticsReportString)
+ openLabel: 'VM Statistics'!
Item was added:
+ ----- Method: TheWorldMenu>>windowsDo (in category 'windows & flaps menu') -----
+ windowsDo
+ "Build the windows menu for the world."
+
+ self doPopUp: self windowsMenu!
Item was added:
+ ----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') -----
+ windowsMenu
+ "Build the windows menu for the world."
+
+ ^ self fillIn: (self menu: 'windows') from: {
+ { 'find window' . { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.'}.
+
+ { 'find changed browsers...' . { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}.
+
+ { 'find changed windows...' . { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}.
+ nil.
+
+ { 'find a transcript (t)' . { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window'}.
+
+ { 'find a fileList (L)' . { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window'}.
+
+ { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}.
+
+ { 'find message names (W)' . { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window'}.
+
+ nil.
+ { #staggerPolicyString . { self . #toggleWindowPolicy }. 'stagger: new windows positioned so you can see a portion of each one.
+ tile: new windows positioned so that they do not overlap others, if possible.'}.
+
+ nil.
+ { 'collapse all windows' . { #myWorld . #collapseAll }. 'Reduce all open windows to collapsed forms that only show titles.'}.
+ { 'expand all windows' . { #myWorld . #expandAll }. 'Expand all collapsed windows back to their expanded forms.'}.
+ { 'close top window (w)' . { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.'}.
+ { 'send top window to back (\)' . { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.'}.
+ { 'move windows onscreen' . { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen'}.
+
+ nil.
+ { 'delete unchanged windows' . { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.'}.
+ { 'delete non-windows' . { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.'}.
+ { 'delete both of the above' . { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.'}.
+
+ }!
Item was added:
+ ----- Method: TheWorldMenu>>world:project:hand: (in category 'mechanics') -----
+ world: aWorld project: aProject hand: aHand
+
+ myWorld := aWorld.
+ myProject := aProject.
+ myHand := aHand.!
Item was added:
+ ----- Method: TheWorldMenu>>worldMenuHelp (in category 'commands') -----
+ worldMenuHelp
+ | explanation aList |
+ "self currentWorld primaryHand worldMenuHelp"
+
+ aList := OrderedCollection new.
+ #(helpMenu changesMenu openMenu debugMenu projectMenu scriptingMenu windowsMenu playfieldMenu appearanceMenu flapsMenu)
+ with:
+ #('help' 'changes' 'open' 'debug' 'projects' 'authoring tools' 'windows' 'playfield options' 'appearance' 'flaps') do:
+ [:sel :title | | aMenu |
+ aMenu := self perform: sel.
+ aMenu items do:
+ [:it | | cnts |
+ (((cnts := it contents) = 'keep this menu up') or: [cnts isEmpty])
+ ifFalse: [aList add: (cnts, ' - ', title translated)]]].
+ aList := aList asSortedCollection: [:a :b | a asLowercase < b asLowercase].
+
+ explanation := String streamContents: [:aStream | aList do:
+ [:anItem | aStream nextPutAll: anItem; cr]].
+
+ (StringHolder new contents: explanation)
+ openLabel: 'Where in the world menu is...' translated!
Item was added:
+ ImageMorph subclass: #ThreePhaseButtonMorph
+ instanceVariableNames: 'offImage pressedImage state target actionSelector arguments actWhen'
+ classVariableNames: 'AuthorModeOwner'
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !ThreePhaseButtonMorph commentStamp: '<historical>' prior: 0!
+ A button morph with separate images for on, off, and pressed with the mouse.
+
+ When the event actWhen occurs, send actionSelector with 'arguments' to target. For other events, default to my eventHandler. The current event is not supplied in the arguments to the actionSelector.
+
+ image (a.k.a. onImage) may not be nil. offImage and pressedImage may be nil. nil there means be transparent and show the underlying object.
+
+ Tools for debugging:
+ Display the images momentarily under program control (for positioning) (self is an instance).
+ self state: #on. self state: #off.
+ self state: #pressed. self state: #off.
+ Display a rectangle where the button is.
+ Display fillWithColor: bounds + (self world viewBox origin).
+ self invalidRect: bounds.!
Item was added:
+ ----- Method: ThreePhaseButtonMorph class>>checkBox (in category 'instance creation') -----
+ checkBox
+ "Answer a button pre-initialized with checkbox images."
+ | f |
+ ^self new
+ onImage: (f := ScriptingSystem formAtKey: 'CheckBoxOn');
+ pressedImage: (ScriptingSystem formAtKey: 'CheckBoxPressed');
+ offImage: (ScriptingSystem formAtKey: 'CheckBoxOff');
+ extent: f extent + (2 at 0);
+ yourself
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "ThreePhaseButtonMorph initialize"
+ | extent inset |
+ extent := 12 at 12.
+ inset := 3.
+
+ #('CheckBoxOff' 'CheckBoxOn' 'CheckBoxPressed') do: [:button |
+ | f r |
+ f := ColorForm extent: extent depth: 1.
+ f colors: {Color transparent. Color black}.
+ f borderWidth: 1.
+ r := f boundingBox insetBy: inset.
+ button = 'CheckBoxPressed' ifTrue: [f border: r width: 1].
+ button = 'CheckBoxOn' ifTrue: [f fillBlack: r].
+ ScriptingSystem saveForm: f atKey: button].
+
+ #('RadioButtonOff' 'RadioButtonOn' 'RadioButtonPressed') do: [:button |
+ | f r c |
+ f := ColorForm extent: extent depth: 1.
+ f colors: {Color transparent. Color black}.
+ r := f boundingBox.
+ c := f getCanvas.
+ c frameOval: r color: Color black.
+ r := r insetBy: inset.
+ button = 'RadioButtonPressed' ifTrue:
+ [c frameOval: r color: Color black].
+ button = 'RadioButtonOn' ifTrue:
+ [c fillOval: r color: Color black].
+ ScriptingSystem saveForm: f atKey: button]!
Item was added:
+ ----- Method: ThreePhaseButtonMorph class>>radioButton (in category 'instance creation') -----
+ radioButton
+ "Answer a button pre-initialized with radiobutton images."
+ | f |
+ ^self new
+ onImage: (f := ScriptingSystem formAtKey: 'RadioButtonOn');
+ pressedImage: (ScriptingSystem formAtKey: 'RadioButtonPressed');
+ offImage: (ScriptingSystem formAtKey: 'RadioButtonOff');
+ extent: f extent + (2 at 0);
+ yourself
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>actWhen: (in category 'submorphs-add/remove') -----
+ actWhen: condition
+ "Accepts symbols: #buttonDown, #buttonUp, and #whilePressed"
+ actWhen := condition!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>actionSelector (in category 'accessing') -----
+ actionSelector
+
+ ^ actionSelector
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>actionSelector: (in category 'accessing') -----
+ actionSelector: aSymbolOrString
+
+ (nil = aSymbolOrString or:
+ ['nil' = aSymbolOrString or:
+ [aSymbolOrString isEmpty]])
+ ifTrue: [^ actionSelector := nil].
+
+ actionSelector := aSymbolOrString asSymbol.
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>arguments (in category 'accessing') -----
+ arguments
+ ^ arguments!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>arguments: (in category 'accessing') -----
+ arguments: aCollection
+
+ arguments := aCollection asArray copy.
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>doButtonAction (in category 'button') -----
+ doButtonAction
+ "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."
+
+ (target notNil and: [actionSelector notNil])
+ ifTrue:
+ [Cursor normal
+ showWhile: [target perform: actionSelector withArguments: arguments].
+ target isMorph ifTrue: [target changed]]!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>doButtonAction: (in category 'event handling') -----
+ doButtonAction: evt
+
+ "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."
+
+ target ifNil: [^self].
+ actionSelector ifNil: [^self].
+ Cursor normal showWhile: [ | moreArgs |
+ moreArgs := actionSelector numArgs > arguments size ifTrue: [
+ arguments copyWith: evt
+ ] ifFalse: [
+ arguments
+ ].
+ target perform: actionSelector withArguments: moreArgs
+ ]!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ state == #off ifTrue: [
+ offImage ifNotNil: [aCanvas translucentImage: offImage at: bounds origin]].
+ state == #pressed ifTrue: [
+ pressedImage ifNotNil: [aCanvas translucentImage: pressedImage at: bounds origin]].
+ state == #on ifTrue: [
+ image ifNotNil: [aCanvas translucentImage: image at: bounds origin]].!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>extent: (in category 'geometry') -----
+ extent: aPoint
+ "Do it normally"
+
+ self changed.
+ bounds := bounds topLeft extent: aPoint.
+ self layoutChanged.
+ self changed.
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+
+ ^ true
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>handlesMouseStillDown: (in category 'event handling') -----
+ handlesMouseStillDown: evt
+ ^actWhen == #whilePressed!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ state := #off.
+ target := nil.
+ actionSelector := #flash.
+ arguments := Array empty.
+ actWhen := #buttonUp
+
+ "self on: #mouseStillDown send: #dragIfAuthoring: to: self."
+ "real move should include a call on dragIfAuthoring: "!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>isOn (in category 'testing') -----
+ isOn
+ ^ state == #on!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ | now dt |
+ self state: #pressed.
+ actWhen == #buttonDown
+ ifTrue:
+ [self doButtonAction]
+ ifFalse:
+ [now := Time millisecondClockValue.
+ super mouseDown: evt.
+ "Allow on:send:to: to set the response to events other than actWhen"
+ dt := Time millisecondClockValue - now max: 0. "Time it took to do"
+ dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
+ self mouseStillDown: evt.!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ (self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #pressed.
+ super mouseMove: evt]
+ "Allow on:send:to: to set the response to events other than actWhen"
+ ifFalse: [self state: #off].
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>mouseStillDown: (in category 'event handling') -----
+ mouseStillDown: evt
+ actWhen == #whilePressed ifFalse:[^self].
+ (self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+ "Allow on:send:to: to set the response to events other than actWhen"
+ actWhen == #buttonUp ifFalse: [^super mouseUp: evt].
+
+ (self containsPoint: evt cursorPoint) ifTrue: [
+ self state: #on.
+ self doButtonAction: evt
+ ] ifFalse: [
+ self state: #off.
+ target ifNotNil: [target mouseUpBalk: evt]
+ ].
+ "Allow owner to keep it selected for radio buttons"
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>offImage (in category 'accessing') -----
+ offImage
+ ^ offImage!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>offImage: (in category 'accessing') -----
+ offImage: aForm
+ offImage := aForm.
+ self invalidRect: self bounds.!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>onImage (in category 'accessing') -----
+ onImage
+ ^ image!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>onImage: (in category 'accessing') -----
+ onImage: aForm
+ image := aForm.
+ self invalidRect: self bounds.!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>pressedImage (in category 'accessing') -----
+ pressedImage
+ ^ pressedImage!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>pressedImage: (in category 'accessing') -----
+ pressedImage: aForm
+ pressedImage := aForm.
+ self invalidRect: self bounds.!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>printOn: (in category 'printing') -----
+ printOn: aStream
+ | string |
+ aStream nextPutAll: '3PButton'.
+ arguments notEmpty
+ ifTrue: [string := arguments at: (2 min: arguments size)].
+ aStream nextPutAll: '('.
+ (string notNil and: [string ~~ self])
+ ifTrue:
+ [aStream
+ print: string;
+ space]
+ ifFalse:
+ [aStream
+ print: actionSelector;
+ space].
+ aStream
+ print: self identityHash;
+ nextPutAll: ')'!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>state: (in category 'accessing') -----
+ state: newState
+ "Change the image and invalidate the rect."
+
+ newState == state ifTrue: [^ self].
+ state := newState.
+ self invalidRect: bounds. "All three images must be the same size"!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>step (in category 'stepping and presenter') -----
+ step
+ (self hasProperty: #doesButtonAction) ifTrue:[
+ self doButtonAction.
+ self setProperty: #didButtonAction toValue: true.
+ ].!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>stepTime (in category 'testing') -----
+ stepTime
+ (self hasProperty: #doesButtonAction) ifTrue:[^1].
+ ^super stepTime!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>target (in category 'accessing') -----
+ target
+
+ ^ target
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>target: (in category 'accessing') -----
+ target: anObject
+
+ target := anObject
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ target := deepCopier references at: target ifAbsent: [target].
+ arguments := arguments collect: [:each |
+ deepCopier references at: each ifAbsent: [each]].
+ !
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment."
+
+ super veryDeepInner: deepCopier.
+ offImage := offImage veryDeepCopyWith: deepCopier.
+ pressedImage := pressedImage veryDeepCopyWith: deepCopier.
+ state := state veryDeepCopyWith: deepCopier.
+ "target := target. Weakly copied"
+ "actionSelector := actionSelector. Symbol"
+ "arguments := arguments. Weakly copied"
+ actWhen := actWhen. "Symbol"!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>wantsSteps (in category 'testing') -----
+ wantsSteps
+ ^(self hasProperty: #doesButtonAction) or:[super wantsSteps]!
Item was added:
+ ImageMorph subclass: #ThumbnailImageMorph
+ instanceVariableNames: 'imagePopupMorph desiredExtent isPopup'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !ThumbnailImageMorph commentStamp: 'wiz 2/19/2006 18:10' prior: 0!
+ A ThumbnailImageMorph is variant of Lex Spoon's CDScreenShotMorph. It displays a thumbnail of the image stored in imagePopupMorph. As a super class of PopupThumbnail morph it is meant to be a thumbnail w/o the popup action. Basicly it provides a scalable thumbnail with the usual morph event behaviors.
+
+ A menu item allows for "photographing" any morph on the screen to become the subject of our images.
+
+ Instance Variables
+ imagePopupMorph: <anImageMorph>
+ image: <aForm>
+ desiredExtent <aPoint>
+ isPopup <aBool>
+ imagePopupMorph
+ - an ImageMorph containing the full sized image.
+ - it can be set from a morph image via the sight target menu item.
+ image
+ - holds the scaled thumbnail form of our imagePopupMorph image.
+ desiredExtent
+ - holds the desired extent that the thumbnail is expected to fit within.
+ - it is guarded to be positive and non-zero.
+ - it can be set by extent: so that the yellow halo handle works.
+ isPopup
+ - true when popup feature is on.
+ - toggled from red halo menu
+
+ Setting the size of the thumbnail works somewhat excentrically because the extent of the thumbnail depends both on the desiredExtent and the aspect ratio of the current popup image.
+
+ With the popup feature off this morph can be picked up and dropped with the mouse.
+ When the feature is on, a full sized snapshot will be seen when the mouse is pressed.
+ Since the mouse can't be used for two things at once, moving the morph must be done with the grab halo or brown move halo.!
Item was added:
+ ----- Method: ThumbnailImageMorph class>>ofDisplay (in category 'examples') -----
+ ofDisplay
+ "ThumbnailImageMorph ofDisplay openInHand"
+ ^self new initializeWithDisplay .!
Item was added:
+ ----- Method: ThumbnailImageMorph>>addCustomMenuItems:hand: (in category 'menu commands') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ self addWorldTargetSightingItems: aCustomMenu hand: aHandMorph .
+ self addPopupMenuItems: aCustomMenu hand: aHandMorph!
Item was added:
+ ----- Method: ThumbnailImageMorph>>addPopupMenuItems:hand: (in category 'menu commands') -----
+ addPopupMenuItems: aCustomMenu hand: aHandMorph
+ " Show and toggle the popUp boolean menu item."
+
+ aCustomMenu addLine.
+
+ aCustomMenu addUpdating: #popupFeatureString target: self
+ selector: #togglePopupFeature argumentList: #() .
+
+ !
Item was added:
+ ----- Method: ThumbnailImageMorph>>extent: (in category 'accessing') -----
+ extent: anExtentPoint
+ "Set the desired extetnt for the thumbnail. It is guarenteed to fit within the desired extent.
+ The desitedExtent is guarded to prevent deviant forms from being attempted."
+
+ self changed . "We might be bigger before we change."
+ desiredExtent := anExtentPoint guarded.
+ self newThumbnail: imagePopupMorph image .
+ !
Item was added:
+ ----- Method: ThumbnailImageMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ ^isPopup == true!
Item was added:
+ ----- Method: ThumbnailImageMorph>>initialize (in category 'initialization') -----
+ initialize
+ super initialize .
+ desiredExtent := 90 asPoint.
+ self newImage: DefaultForm!
Item was added:
+ ----- Method: ThumbnailImageMorph>>initializeWithDisplay (in category 'initialization') -----
+ initializeWithDisplay
+ super initialize .
+ desiredExtent := 90 asPoint.
+ self newImage: Display!
Item was added:
+ ----- Method: ThumbnailImageMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+
+
+ imagePopupMorph center: (self localPointToGlobal: evt position).
+ imagePopupMorph bounds: (imagePopupMorph bounds translatedAndSquishedToBeWithin: World bounds).
+ imagePopupMorph openInWorld
+ !
Item was added:
+ ----- Method: ThumbnailImageMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+ imagePopupMorph ifNotNil: [
+ imagePopupMorph delete .
+ ]!
Item was added:
+ ----- Method: ThumbnailImageMorph>>newImage: (in category 'accessing') -----
+ newImage: aForm
+ "Use aForm as the new popupImage and update the thumbnail image."
+
+ imagePopupMorph
+ ifNil: [ imagePopupMorph := aForm asMorph]
+ ifNotNil: [ imagePopupMorph image: aForm ] .
+
+ self newThumbnail: aForm
+
+ !
Item was added:
+ ----- Method: ThumbnailImageMorph>>newThumbnail: (in category 'accessing') -----
+ newThumbnail: aForm
+ "Use aForm as the new popupImage and update the thumbnail image."
+ | scale thumbForm border smoothing |
+
+ scale := aForm extent scaleTo: desiredExtent .
+ smoothing := (scale x < 1.0 or: [ scale y < 1.0 ]) ifTrue: [ 2 ] ifFalse: [ 1 ] .
+
+ thumbForm := aForm magnify: aForm boundingBox by: scale smoothing: smoothing .
+
+ self image: thumbForm . "heres where we put in a thumbnail"
+ "We need the following to keep the border the right size. Otherwise it will shrink."
+ (border := self borderStyle) == BorderStyle default ifFalse: [ self borderStyle: border ] .
+
+ "We have changed clear the old and show the new"
+ self invalidRect: self bounds . !
Item was added:
+ ----- Method: ThumbnailImageMorph>>popupFeatureString (in category 'accessing') -----
+ popupFeatureString
+ "Answer the string to be shown in a menu to represent the
+ stickiness status"
+ ^ (self yesNoStringFor: (isPopup == true ) )
+ , 'Popup feature' translated!
Item was added:
+ ----- Method: ThumbnailImageMorph>>target: (in category 'accessing') -----
+ target: aMorph
+ "Snap aMorphs current image and show its thumbnail"
+
+ self newImage: aMorph imageForm fixAlpha .
+ !
Item was added:
+ ----- Method: ThumbnailImageMorph>>togglePopupFeature (in category 'accessing') -----
+ togglePopupFeature
+ "Change the popup behaviour. Return the new boolean value."
+
+ ^isPopup := isPopup ~~ true .
+ !
Item was added:
+ ----- Method: ThumbnailImageMorph>>yesNoStringFor: (in category 'accessing') -----
+ yesNoStringFor: aBool
+ "Answer the string to be shown in a menu to represent the
+ yes/no status"
+ ^ (aBool
+ ifTrue: ['<yes>']
+ ifFalse: ['<no>'])
+ !
Item was added:
+ BorderGripMorph subclass: #TopGripMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: TopGripMorph>>apply: (in category 'target resize') -----
+ apply: delta
+ | oldBounds |
+ oldBounds := target bounds.
+ target
+ bounds: (oldBounds origin + (0 @ delta y) corner: oldBounds corner)!
Item was added:
+ ----- Method: TopGripMorph>>defaultHeight (in category 'initialize') -----
+ defaultHeight
+
+ ^ 5!
Item was added:
+ ----- Method: TopGripMorph>>gripLayoutFrame (in category 'accessing') -----
+ gripLayoutFrame
+ ^ LayoutFrame
+ fractions: (0 @ 0 corner: 1 @ 0)
+ offsets: (0 @ -40 corner: 0@ 0)!
Item was added:
+ ----- Method: TopGripMorph>>initialize (in category 'initialize') -----
+ initialize
+ super initialize.
+ self hResizing: #spaceFill.!
Item was added:
+ ----- Method: TopGripMorph>>ptName (in category 'accessing') -----
+ ptName
+ ^#top!
Item was added:
+ ----- Method: TopGripMorph>>resizeCursor (in category 'accessing') -----
+ resizeCursor
+
+ ^ Cursor resizeForEdge: #top!
Item was added:
+ CornerGripMorph subclass: #TopLeftGripMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !TopLeftGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0!
+ I am the handle in the left top of windows used for resizing them.!
Item was added:
+ ----- Method: TopLeftGripMorph>>apply: (in category 'target resize') -----
+ apply: delta
+ | oldBounds |
+ oldBounds := target bounds.
+ target
+ bounds: (oldBounds origin + delta corner: oldBounds corner)!
Item was added:
+ ----- Method: TopLeftGripMorph>>borderOffset (in category 'private') -----
+ borderOffset
+ |width|
+ width :=SystemWindow borderWidth +1.
+ ^self handleOrigin + width asPoint!
Item was added:
+ ----- Method: TopLeftGripMorph>>gripLayoutFrame (in category 'accessing') -----
+ gripLayoutFrame
+ ^ LayoutFrame
+ fractions: (0 @ 0 corner: 0 @ 0)
+ offsets: (0 @ 0 corner: self defaultWidth @ 0)!
Item was added:
+ ----- Method: TopLeftGripMorph>>handleOrigin (in category 'private') -----
+ handleOrigin
+ ^25 at 25!
Item was added:
+ ----- Method: TopLeftGripMorph>>layoutProportionallyIn: (in category 'layout') -----
+ layoutProportionallyIn: newBounds
+ | b |
+ b := owner bounds.
+ self bounds: (b topLeft extent: self extent)
+ !
Item was added:
+ ----- Method: TopLeftGripMorph>>ptName (in category 'target resize') -----
+ ptName
+ ^#topLeft!
Item was added:
+ ----- Method: TopLeftGripMorph>>resizeCursor (in category 'accessing') -----
+ resizeCursor
+
+ ^ Cursor resizeForEdge: #topLeft!
Item was added:
+ CornerGripMorph subclass: #TopRightGripMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !TopRightGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0!
+ I am the handle in the right top of windows used for resizing them.!
Item was added:
+ ----- Method: TopRightGripMorph>>apply: (in category 'target resize') -----
+ apply: delta
+ | oldBounds |
+ oldBounds := target bounds.
+ target
+ bounds: (oldBounds origin + (0 at delta y) corner: oldBounds corner + (delta x @ 0))!
Item was added:
+ ----- Method: TopRightGripMorph>>borderOffset (in category 'private') -----
+ borderOffset
+ |width|
+ width :=SystemWindow borderWidth +1 .
+ ^self handleOrigin + ( width negated @ (width) )!
Item was added:
+ ----- Method: TopRightGripMorph>>gripLayoutFrame (in category 'accessing') -----
+ gripLayoutFrame
+ ^ LayoutFrame
+ fractions: (1 @ 0 corner: 1 @ nil)
+ offsets: (0 - self defaultWidth @ 0 corner: 0 @ nil)!
Item was added:
+ ----- Method: TopRightGripMorph>>handleOrigin (in category 'private') -----
+ handleOrigin
+ ^0 at 25!
Item was added:
+ ----- Method: TopRightGripMorph>>layoutProportionallyIn: (in category 'layout') -----
+ layoutProportionallyIn: newBounds
+ | b |
+ b := owner bounds.
+
+ self bounds: (b right - self width @ b top extent: self extent)
+ !
Item was added:
+ ----- Method: TopRightGripMorph>>ptName (in category 'accessing') -----
+ ptName
+ ^#topRight!
Item was added:
+ ----- Method: TopRightGripMorph>>resizeCursor (in category 'accessing') -----
+ resizeCursor
+
+ ^ Cursor resizeForEdge: #topRight!
Item was added:
+ ----- Method: Transcripter>>morphicDisplayText (in category '*Morphic') -----
+ morphicDisplayText
+ para compose: self contents asText
+ style: TextStyle default
+ from: 1
+ in: frame.
+ Display
+ fill: (frame insetBy: -2) fillColor: self black;
+ fill: frame fillColor: self white.
+ Display getCanvas
+ paragraph: para
+ bounds: (4 at 4 + frame topLeft extent: Display extent)
+ color: Color black!
Item was added:
+ ----- Method: Transcripter>>morphicInitializeParagraph: (in category '*Morphic') -----
+ morphicInitializeParagraph: classParagraph
+ para := classParagraph new.
+ para compose: self contents asText
+ style: TextStyle default
+ from: 1
+ in: frame
+ !
Item was added:
+ Morph subclass: #TransferMorph
+ instanceVariableNames: 'transferType passenger draggedMorph source dropNotifyRecipient resultRecipient copy'
+ classVariableNames: 'CopyPlusIcon'
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
+
+ !TransferMorph commentStamp: 'nk 6/16/2003 16:52' prior: 0!
+ This is a Morph that is used to visually indicate the progress of a drag operation, and also as a container for various bits of drag state information.
+
+ It polls the shift state in its step method to update its copy state (shift pressed = should copy).
+
+ And if you hit the Escape key while dragging, it aborts the drag operation.!
Item was added:
+ ----- Method: TransferMorph class>>initIcons (in category 'class initialization') -----
+ initIcons
+ "TransferMorph initIcons"
+
+ CopyPlusIcon := Form
+ extent: 16 at 16
+ depth: 8
+ fromArray: #( 0 0 65535 0 0 0 16768220 4278190080 0 0 16768220 4278190080 0 255 4294958300 4294967040 0 65500 3705461980 3705462015 0 65500 3705461980 3705462015 0 255 4294958300 4294967295 0 0 16768220 4278190080 0 0 16768220 4278190080 0 0 65535 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
+ offset: 0 at 0!
Item was added:
+ ----- Method: TransferMorph class>>initialize (in category 'class initialization') -----
+ initialize
+ "TransferMorph initialize"
+
+ self initIcons!
Item was added:
+ ----- Method: TransferMorph class>>withPassenger: (in category 'instance creation') -----
+ withPassenger: anObject
+ ^ self withPassenger: anObject from: nil!
Item was added:
+ ----- Method: TransferMorph class>>withPassenger:from: (in category 'instance creation') -----
+ withPassenger: anObject from: source
+ | ddm |
+ ddm := self new.
+ ddm passenger: anObject.
+ ddm source: source.
+ Sensor shiftPressed ifTrue: [ddm shouldCopy: true].
+ ^ ddm!
Item was added:
+ ----- Method: TransferMorph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
+ aboutToBeGrabbedBy: aHand
+ "The receiver is being grabbed by a hand.
+ Perform necessary adjustments (if any) and return the actual morph
+ that should be added to the hand."
+ "Since this morph has been initialized automatically with bounds origin
+ 0 at 0, we have to move it to aHand position."
+ super aboutToBeGrabbedBy: aHand.
+ self draggedMorph.
+ self align: self bottomLeft with: aHand position.
+ aHand newKeyboardFocus: self.!
Item was added:
+ ----- Method: TransferMorph>>animationForMoveSuccess: (in category 'private') -----
+ animationForMoveSuccess: success
+ | start stop slideForm |
+ success
+ ifTrue: [^ self]
+ ifFalse:
+ [start := self fullBounds origin.
+ stop := self source bounds origin].
+ start = stop ifTrue: [^ self].
+ slideForm := self imageFormForRectangle: ((self fullBounds origin corner: self fullBounds corner + self activeHand shadowOffset)
+ merge: self activeHand bounds).
+ slideForm offset: 0 @ 0.
+ slideForm
+ slideWithFirstFrom: start
+ to: stop
+ nSteps: 12
+ delay: 20!
Item was added:
+ ----- Method: TransferMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color blue alpha: 0.4!
Item was added:
+ ----- Method: TransferMorph>>delete (in category 'submorphs-add/remove') -----
+ delete
+ "See also >>justDroppedInto:event:."
+ self changed: #deleted.
+ self breakDependents.
+ super delete!
Item was added:
+ ----- Method: TransferMorph>>dragTransferType (in category 'drag and drop') -----
+ dragTransferType
+ ^transferType!
Item was added:
+ ----- Method: TransferMorph>>dragTransferType: (in category 'accessing') -----
+ dragTransferType: aSymbol
+ transferType := aSymbol!
Item was added:
+ ----- Method: TransferMorph>>draggedMorph (in category 'accessing') -----
+ draggedMorph
+ draggedMorph ifNil: [self initDraggedMorph].
+ ^draggedMorph!
Item was added:
+ ----- Method: TransferMorph>>draggedMorph: (in category 'accessing') -----
+ draggedMorph: aMorph
+ draggedMorph := aMorph!
Item was added:
+ ----- Method: TransferMorph>>initDraggedMorph (in category 'private') -----
+ initDraggedMorph
+ draggedMorph ifNotNil: [^self].
+ draggedMorph := self passenger asDraggableMorph.
+ self addMorphBack: draggedMorph.
+ self updateCopyIcon.
+ self changed; fullBounds!
Item was added:
+ ----- Method: TransferMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ self layoutPolicy: TableLayout new.
+ self listDirection: #leftToRight;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ layoutInset: 3;
+ wrapCentering: #center;
+ cellPositioning: #leftCenter.
+ copy := false.
+ self on: #keyStroke send: #keyStroke: to: self!
Item was added:
+ ----- Method: TransferMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
+ justDroppedInto: targetMorph event: anEvent
+ "If only world wants this TransferMorph, treat it as unaccepted (see also >>delete)."
+ super
+ justDroppedInto: targetMorph
+ event: anEvent.
+ self animationForMoveSuccess: true.
+ self delete!
Item was added:
+ ----- Method: TransferMorph>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+ "Abort the drag on an escape"
+ evt keyCharacter ~= Character escape ifTrue: [ ^self ].
+ self delete.!
Item was added:
+ ----- Method: TransferMorph>>morphToDropInPasteUp: (in category 'dropping/grabbing') -----
+ morphToDropInPasteUp: aPasteUpMorph
+ ^ aPasteUpMorph morphToDropForTransferMorph: self!
Item was added:
+ ----- Method: TransferMorph>>move (in category 'accessing') -----
+ move
+ copy := false!
Item was added:
+ ----- Method: TransferMorph>>passenger (in category 'accessing') -----
+ passenger
+ ^passenger!
Item was added:
+ ----- Method: TransferMorph>>passenger: (in category 'accessing') -----
+ passenger: anObject
+ passenger := anObject!
Item was added:
+ ----- Method: TransferMorph>>privateFullMoveBy: (in category 'private') -----
+ privateFullMoveBy: delta
+ super privateFullMoveBy: delta.
+ self changed: #position!
Item was added:
+ ----- Method: TransferMorph>>shouldCopy (in category 'accessing') -----
+ shouldCopy
+ ^copy!
Item was added:
+ ----- Method: TransferMorph>>shouldCopy: (in category 'accessing') -----
+ shouldCopy: aBoolean
+ copy := aBoolean.!
Item was added:
+ ----- Method: TransferMorph>>source (in category 'accessing') -----
+ source
+ ^source!
Item was added:
+ ----- Method: TransferMorph>>source: (in category 'accessing') -----
+ source: anObject
+ source := anObject!
Item was added:
+ ----- Method: TransferMorph>>step (in category 'stepping and presenter') -----
+ step
+ self shouldCopy: self primaryHand lastEvent shiftPressed.
+ self updateCopyIcon!
Item was added:
+ ----- Method: TransferMorph>>stepTime (in category 'stepping and presenter') -----
+ stepTime
+ ^100!
Item was added:
+ ----- Method: TransferMorph>>undoGrabCommand (in category 'dropping/grabbing') -----
+ undoGrabCommand
+ ^nil!
Item was added:
+ ----- Method: TransferMorph>>updateCopyIcon (in category 'private') -----
+ updateCopyIcon
+ | copyIcon |
+ copyIcon := self submorphWithProperty: #tmCopyIcon.
+ (self shouldCopy and: [ copyIcon isNil ]) ifTrue: [
+ ^self addMorphFront: ((ImageMorph new image: CopyPlusIcon) setProperty: #tmCopyIcon toValue: true)
+ ].
+ (self shouldCopy not and: [ copyIcon notNil ]) ifTrue: [
+ copyIcon delete
+ ]!
Item was added:
+ ----- Method: TransferMorph>>wantsToBeDroppedInto: (in category 'dropping/grabbing') -----
+ wantsToBeDroppedInto: aMorph
+ ^ aMorph isWorldMorph
+ ifTrue: [ aMorph hasTransferMorphConverter ]
+ ifFalse: [ super wantsToBeDroppedInto: aMorph ]!
Item was added:
+ Morph subclass: #TransferMorphAnimation
+ instanceVariableNames: 'transferMorph'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: TransferMorphAnimation class>>on: (in category 'instance creation') -----
+ on: aTransferMorph
+ ^self new on: aTransferMorph!
Item was added:
+ ----- Method: TransferMorphAnimation>>on: (in category 'initialization') -----
+ on: aTransferMorph
+
+ self flag: #bob. "there was a reference to World, but the class seems to be unused"
+
+ self color: Color transparent.
+ transferMorph := aTransferMorph.
+ transferMorph addDependent: self.
+ ActiveWorld addMorph: self "or perhaps aTransferMorph world"!
Item was added:
+ ----- Method: TransferMorphAnimation>>transferMorph (in category 'accessing') -----
+ transferMorph
+ ^transferMorph!
Item was added:
+ ----- Method: TransferMorphAnimation>>update: (in category 'updating') -----
+ update: aSymbol
+ aSymbol == #deleted
+ ifTrue: [self delete].
+ aSymbol == #position
+ ifTrue: [self updateAnimation].
+ self changed!
Item was added:
+ ----- Method: TransferMorphAnimation>>updateAnimation (in category 'update') -----
+ updateAnimation!
Item was added:
+ TransferMorphAnimation subclass: #TransferMorphLineAnimation
+ instanceVariableNames: 'polygon'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!
Item was added:
+ ----- Method: TransferMorphLineAnimation>>initPolygon (in category 'initialization') -----
+ initPolygon
+ polygon := (LineMorph from: self transferMorph source bounds center
+ to: self transferMorph bounds center
+ color: Color black width: 2)
+ dashedBorder: {10. 10. Color white}.
+ self addMorph: polygon
+ !
Item was added:
+ ----- Method: TransferMorphLineAnimation>>on: (in category 'initialization') -----
+ on: aTransferMorph
+ super on: aTransferMorph.
+ self initPolygon!
Item was added:
+ ----- Method: TransferMorphLineAnimation>>updateAnimation (in category 'update') -----
+ updateAnimation
+ polygon verticesAt: 2 put: self transferMorph center!
Item was added:
+ Morph subclass: #TransformMorph
+ instanceVariableNames: 'transform smoothing localBounds'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !TransformMorph commentStamp: 'wiz 11/6/2005 15:59' prior: 0!
+ A TransformMorph introduces a 2-D transformation between its (global) coordinates and the (local) coordinates of its submorphs, while also clipping all display to its bounds. Specifically, with no offset, angle or scaling, a submorph with coordinates (0 at 0) will appear exactly at the topLeft of the windowMorph (its position). Rotation and scaling are relative to the local origin, (0 at 0).
+
+ instance var type description
+ transform MorphicTransform The coordinate transform between my coordinates and the
+ local coordinates of my submorphs.
+ smoothing anInteger in 1..3 Perform smoothing of my contents during drawing
+ 1 No smoothing (#smoothingOff)
+ 2 Smoothing w/ edge adjacent pixels (#smoothingOn)
+ 3 Smoothing w/ edge and corner adj pixels
+
+ localBounds Rectangle or nil caches the value of #localSubmorphBounds for performance
+
+ TransformMorphs operate with two different display strategies, depending on whether the transformation is a pure translation or not. If so, then they simply use a clipping canvas and display their submorphs with the appropriate offset. If the transformation includes scaling or rotation, then a caching canvas is used, whose active area covers the fullBounds of the submorphs intersected with the source quadrilateral corresponding to the window bounds.!
Item was added:
+ ----- Method: TransformMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aCustomMenu hand: aHandMorph
+ super addCustomMenuItems: aCustomMenu hand: aHandMorph.
+ smoothing = 1
+ ifTrue: [aCustomMenu add: 'turn on smoothing' translated action: #smoothingOn]
+ ifFalse: [aCustomMenu add: 'turn off smoothing' translated action: #smoothingOff]!
Item was added:
+ ----- Method: TransformMorph>>angle (in category 'accessing') -----
+ angle
+ ^ transform angle!
Item was added:
+ ----- Method: TransformMorph>>angle: (in category 'accessing') -----
+ angle: newAngle
+
+ self changed.
+ transform := transform withAngle: newAngle.
+ self layoutChanged.
+ self changed!
Item was added:
+ ----- Method: TransformMorph>>colorForInsets (in category 'accessing') -----
+ colorForInsets
+ ^ owner ifNil: [color] ifNotNil: [owner color]!
Item was added:
+ ----- Method: TransformMorph>>containsPoint: (in category 'geometry testing') -----
+ containsPoint: aPoint
+ (bounds containsPoint: aPoint) ifFalse: [^ false].
+ self hasSubmorphs
+ ifTrue: [ | localPoint | localPoint := (transform globalPointToLocal: aPoint) .
+ self submorphsDo:
+ [:m | (m containsPoint: localPoint)
+ ifTrue: [^ true]].
+ ^ false]
+ ifFalse: [^ true]!
Item was added:
+ ----- Method: TransformMorph>>defaultColor (in category 'initialization') -----
+ defaultColor
+ "answer the default color/fill style for the receiver"
+ ^ Color lightGreen!
Item was added:
+ ----- Method: TransformMorph>>drawSubmorphsOn: (in category 'drawing') -----
+ drawSubmorphsOn: aCanvas
+
+ aCanvas transformBy: transform
+ clippingTo: self innerBounds
+ during: [:myCanvas |
+ (self angle ~= 0.0 or: [self scale ~= 1.0])
+ ifTrue:[
+ AbstractFont forceNonSubPixelDuring:[
+ submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] ]
+ ifFalse:[
+ submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] ]
+ smoothing: smoothing!
Item was added:
+ ----- Method: TransformMorph>>grabTransform (in category 'dropping/grabbing') -----
+ grabTransform
+ "Return the transform for the receiver which should be applied during grabbing"
+ ^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]!
Item was added:
+ ----- Method: TransformMorph>>initialize (in category 'initialization') -----
+ initialize
+ "initialize the state of the receiver"
+ super initialize.
+ ""
+
+ smoothing := 1.
+ transform := MorphicTransform identity.
+ self clipSubmorphs: true.!
Item was added:
+ ----- Method: TransformMorph>>invalidRect:from: (in category 'change reporting') -----
+ invalidRect: damageRect from: aMorph
+ "Translate damage reports from submorphs by the scrollOffset."
+ aMorph == self
+ ifTrue:[super invalidRect: damageRect from: self]
+ ifFalse:[super invalidRect: (((transform localBoundsToGlobal: damageRect) intersect: bounds) expandBy: 1) from: self].!
Item was added:
+ ----- Method: TransformMorph>>layoutBounds (in category 'layout') -----
+ layoutBounds
+
+ ^ (transform globalBoundsToLocal: super layoutBounds) truncated
+ !
Item was added:
+ ----- Method: TransformMorph>>layoutChanged (in category 'geometry') -----
+ layoutChanged
+
+ "A submorph could have moved, thus changing my localBounds. Invalidate the cache."
+ localBounds := nil.
+
+ ^super layoutChanged!
Item was added:
+ ----- Method: TransformMorph>>localSubmorphBounds (in category 'geometry') -----
+ localSubmorphBounds
+ "Answer, in my coordinate system, the bounds of all my submorphs (or nil if no submorphs). We will cache this value for performance. The value is invalidated upon recieving #layoutChanged."
+
+ localBounds ifNil:[
+ self submorphsDo:[:m |
+ localBounds ifNil: [localBounds := m fullBounds]
+ ifNotNil: [localBounds := localBounds quickMerge: m fullBounds]].
+ ].
+
+ ^ localBounds!
Item was added:
+ ----- Method: TransformMorph>>localVisibleSubmorphBounds (in category 'geometry') -----
+ localVisibleSubmorphBounds
+ "Answer, in my coordinate system, the bounds of all my visible submorphs (or nil if no visible submorphs)"
+ | subBounds |
+ subBounds := nil.
+ self submorphsDo: [:m |
+ (m visible) ifTrue: [
+ subBounds
+ ifNil: [subBounds := m fullBounds copy]
+ ifNotNil: [subBounds := subBounds quickMerge: m fullBounds]]
+ ].
+ ^subBounds!
Item was added:
+ ----- Method: TransformMorph>>numberOfItemsInView (in category 'geometry') -----
+ numberOfItemsInView
+ "Answer the number of my submorphs whose (transformed) bounds intersect mine.
+ This includes items that are only partially visible.
+ Ignore visibility of submorphs."
+
+ ^(submorphs select: [ :ea | self innerBounds intersects: (transform localBoundsToGlobal: ea bounds) ]) size!
Item was added:
+ ----- Method: TransformMorph>>numberOfItemsPotentiallyInView (in category 'geometry') -----
+ numberOfItemsPotentiallyInView
+ "Answer the number of items that could potentially be viewed in full,
+ computed as my visible height divided by the average height of my submorphs.
+ Ignore visibility of submorphs."
+
+ ^self innerBounds height // (self localSubmorphBounds height / submorphs size)!
Item was added:
+ ----- Method: TransformMorph>>numberOfItemsPotentiallyInViewWith: (in category 'geometry') -----
+ numberOfItemsPotentiallyInViewWith: submorphCount
+ "Answer the number of items that could potentially be viewed in full,
+ computed as my visible height divided by the average height of my submorphs.
+ Ignore visibility of submorphs."
+
+ ^self innerBounds height // (self localSubmorphBounds height / submorphCount)!
Item was added:
+ ----- Method: TransformMorph>>offset (in category 'accessing') -----
+ offset
+ ^ transform offset + self innerBounds topLeft!
Item was added:
+ ----- Method: TransformMorph>>offset: (in category 'accessing') -----
+ offset: newOffset
+
+ transform := transform withOffset: newOffset - self innerBounds topLeft.
+ self changed!
Item was added:
+ ----- Method: TransformMorph>>privateFullMoveBy: (in category 'private') -----
+ privateFullMoveBy: delta
+ "Private!! Relocate me, but not my subMorphs."
+
+ self privateMoveBy: delta.
+ transform := (transform asMorphicTransform) withOffset: (transform offset - delta).
+ !
Item was added:
+ ----- Method: TransformMorph>>scale (in category 'accessing') -----
+ scale
+ ^ transform scale!
Item was added:
+ ----- Method: TransformMorph>>scale: (in category 'accessing') -----
+ scale: newScale
+
+ self changed.
+ transform := transform withScale: newScale.
+ self layoutChanged.
+ self changed.
+ !
Item was added:
+ ----- Method: TransformMorph>>setOffset:angle:scale: (in category 'accessing') -----
+ setOffset: newOffset angle: newAngle scale: newScale
+
+ transform := MorphicTransform offset: newOffset angle: newAngle scale: newScale.
+ self changed!
Item was added:
+ ----- Method: TransformMorph>>smoothing (in category 'accessing') -----
+ smoothing
+ ^smoothing
+ !
Item was added:
+ ----- Method: TransformMorph>>smoothing: (in category 'accessing') -----
+ smoothing: cellSize
+ smoothing := cellSize.
+ self changed!
Item was added:
+ ----- Method: TransformMorph>>smoothingOff (in category 'accessing') -----
+ smoothingOff
+ smoothing := 1.
+ self changed!
Item was added:
+ ----- Method: TransformMorph>>smoothingOn (in category 'accessing') -----
+ smoothingOn
+ smoothing := 2.
+ self changed!
Item was added:
+ ----- Method: TransformMorph>>submorphBounds (in category 'layout') -----
+ submorphBounds
+ "Answer, in owner coordinates, the bounds of my visible submorphs, or my bounds"
+ | box |
+ box := self localVisibleSubmorphBounds.
+ ^(box ifNotNil: [ transform localBoundsToGlobal: box ] ifNil: [ self bounds ]) truncated.
+ !
Item was added:
+ ----- Method: TransformMorph>>transform (in category 'accessing') -----
+ transform
+ ^transform!
Item was added:
+ ----- Method: TransformMorph>>transform: (in category 'accessing') -----
+ transform: aTransform
+ transform := aTransform.!
Item was added:
+ ----- Method: TransformMorph>>transformFrom: (in category 'event handling') -----
+ transformFrom: uberMorph
+ "Return a transform to map coorinates of uberMorph, a morph above me in my owner chain, into the coordinates of my submorphs."
+
+ (self == uberMorph or: [owner isNil]) ifTrue: [^transform].
+ ^(owner transformFrom: uberMorph) composedWithLocal: transform!
Item was added:
+ ----- Method: TransformMorph>>wantsHaloFromClick (in category 'halos and balloon help') -----
+ wantsHaloFromClick
+ ^ false!
Item was added:
+ TransformMorph subclass: #TransformationMorph
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Basic'!
+
+ !TransformationMorph commentStamp: 'mk 8/16/2005 11:58' prior: 0!
+ A TransformationMorph is like a transformMorph, except that it does not clip, and its bounds include its entire submorph. TransformationMorphs are assumed to have only one submorph -- the idea is that it is a wrapper that enables its submorph to scale and rotate. A TMorph may come to have more than one submorph if, eg, a menu sprouts a sub menu, using the transformationMorph temporarily as its world, but this ability is only sparsely supported (as in layoutChanged).
+
+ See TransformationMorph class example1 method.!
Item was added:
+ ----- Method: TransformationMorph class>>example1 (in category 'example') -----
+ example1
+ | stringMorph transformationMorph |
+ stringMorph := 'vertical text' asMorph.
+ transformationMorph := TransformationMorph new asFlexOf: stringMorph.
+ transformationMorph angle: Float pi / 2.
+ transformationMorph position: 5 at 5.
+ transformationMorph openInWorld.!
Item was added:
+ ----- Method: TransformationMorph>>adjustAfter: (in category 'private') -----
+ adjustAfter: changeBlock
+ "Cause this morph to remain cetered where it was before, and
+ choose appropriate smoothing, after a change of scale or rotation."
+ | oldRefPos |
+ oldRefPos := self referencePosition.
+ changeBlock value.
+ self chooseSmoothing.
+ self actorStateOrNil ifNotNil:[
+ self penUpWhile: [self position: self position + (oldRefPos - self referencePosition)].
+ ].
+ self layoutChanged.
+ owner ifNotNil: [owner invalidRect: bounds]
+ !
Item was added:
+ ----- Method: TransformationMorph>>asFlexOf: (in category 'initialization') -----
+ asFlexOf: aMorph
+ "Initialize me with position and bounds of aMorph,
+ and with an offset that provides centered rotation."
+ | pos |
+ pos := aMorph position.
+ self addMorph: aMorph.
+ aMorph position: (aMorph extent // 2) negated.
+ self position: pos.
+ transform := transform withOffset: aMorph position - pos
+ !
Item was added:
+ ----- Method: TransformationMorph>>chooseSmoothing (in category 'private') -----
+ chooseSmoothing
+ "Choose appropriate smoothing, after a change of scale or rotation."
+
+ smoothing := (self scale < 1.0 or: [self angle ~= (self angle roundTo: Float pi / 2.0)])
+ ifTrue: [ 2]
+ ifFalse: [1]!
Item was added:
+ ----- Method: TransformationMorph>>computeBounds (in category 'geometry') -----
+ computeBounds
+ self hasSubmorphs ifTrue:
+ [bounds := (transform localBoundsToGlobal:
+ (Rectangle merging:
+ (self submorphs collect: [:m | m fullBounds]))) truncated
+ expandBy: 1].
+ fullBounds := bounds.!
Item was added:
+ ----- Method: TransformationMorph>>degreesOfFlex (in category 'geometry eToy') -----
+ degreesOfFlex
+ "Return any rotation due to flexing"
+ ^ self rotationDegrees!
Item was added:
+ ----- Method: TransformationMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+ submorphs isEmpty ifTrue: [super drawOn: aCanvas]!
Item was added:
+ ----- Method: TransformationMorph>>extent: (in category 'geometry') -----
+ extent: newExtent
+
+ self adjustAfter:
+ [ | scaleFactor |
+ scaleFactor := (self scale * newExtent r / self fullBounds extent r) max: 0.1.
+ self scale: (scaleFactor detentBy: 0.1 atMultiplesOf: 1.0 snap: false)]!
Item was added:
+ ----- Method: TransformationMorph>>flexing:byTransformation: (in category 'initialization') -----
+ flexing: aMorph byTransformation: tfm
+ "Initialize me with position and bounds of aMorph,
+ and with an offset that provides centered rotation."
+
+ (aMorph isKindOf: TransformationMorph)
+ ifTrue: [aMorph submorphsDo: [:m | self addMorph: m clone]]
+ ifFalse: [self addMorph: aMorph].
+ transform := tfm.
+ self chooseSmoothing.
+ self layoutChanged.!
Item was added:
+ ----- Method: TransformationMorph>>forwardDirection (in category 'accessing') -----
+ forwardDirection
+ "Return the rendee's forward direction.
+ If I have no rendee then return 0.0 degrees "
+ | rendee |
+ ( rendee := self renderedMorph) == self ifTrue: [ ^ 0.0 ] .
+
+ ^ rendee forwardDirection!
Item was added:
+ ----- Method: TransformationMorph>>forwardDirection: (in category 'geometry eToy') -----
+ forwardDirection: degrees
+ "If we have a rendee set its forward direction. Else do nothing."
+
+ | rendee |
+ ( rendee := self renderedMorph) == self ifTrue: [ ^ self ] .
+ ^rendee forwardDirection: degrees!
Item was added:
+ ----- Method: TransformationMorph>>grabTransform (in category 'dropping/grabbing') -----
+ grabTransform
+ "Return the transform for the receiver which should be applied during grabbing"
+ self renderedMorph isWorldMorph
+ ifTrue:[^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]].
+ ^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]!
Item was added:
+ ----- Method: TransformationMorph>>hasNoScaleOrRotation (in category 'accessing') -----
+ hasNoScaleOrRotation
+
+ ^ transform isPureTranslation
+ !
Item was added:
+ ----- Method: TransformationMorph>>heading (in category 'geometry eToy') -----
+ heading
+ "End recusion when necessary."
+ | rendee |
+ (rendee := self renderedMorph) == self ifTrue: [ ^0.0 ] .
+ ^ rendee heading!
Item was added:
+ ----- Method: TransformationMorph>>heading: (in category 'geometry eToy') -----
+ heading: newHeading
+ "If we have a rendee set its heading. Else do nothing."
+
+ | rendee |
+ ( rendee := self renderedMorph) == self ifTrue: [ ^ self ] .
+ ^rendee heading: newHeading!
Item was added:
+ ----- Method: TransformationMorph>>innocuousName (in category 'naming') -----
+ innocuousName
+ | r |
+ ^ (r := self renderedMorph) == self
+ ifTrue: [super innocuousName] ifFalse: [r innocuousName]!
Item was added:
+ ----- Method: TransformationMorph>>isFlexMorph (in category 'classification') -----
+ isFlexMorph
+
+ ^ true
+ !
Item was added:
+ ----- Method: TransformationMorph>>isRenderer (in category 'classification') -----
+ isRenderer
+
+ ^ true
+ !
Item was added:
+ ----- Method: TransformationMorph>>isSticky (in category 'testing') -----
+ isSticky
+ submorphs isEmpty ifFalse: [ ^ submorphs first isSticky ] .
+
+ ^false!
Item was added:
+ ----- Method: TransformationMorph>>layoutChanged (in category 'layout') -----
+ layoutChanged
+ "Recompute bounds as a result of change"
+ self computeBounds.
+ super layoutChanged!
Item was added:
+ ----- Method: TransformationMorph>>printOn: (in category 'printing') -----
+ printOn: aStream
+ super printOn: aStream.
+ submorphs isEmpty
+ ifTrue: [aStream nextPutAll: ' with no transformee!!']
+ ifFalse: [aStream nextPutAll: ' on ' , submorphs first printString]!
Item was added:
+ ----- Method: TransformationMorph>>referencePosition (in category 'geometry eToy') -----
+ referencePosition
+ "Answer the receiver's reference position, bullet-proofed against infinite recursion in the unlikely but occasionally-seen case that I am my own renderee"
+
+ | rendered |
+ ^ (rendered := self renderedMorph) == self
+ ifTrue:
+ [super referencePosition]
+ ifFalse:
+ [transform localPointToGlobal: rendered referencePosition]!
Item was added:
+ ----- Method: TransformationMorph>>removeFlexShell (in category 'menu') -----
+ removeFlexShell
+ "Remove the shell used to make a morph rotatable and scalable."
+
+ | oldHalo unflexed pensDown myWorld refPos aPosition |
+ refPos := self referencePosition.
+ myWorld := self world.
+ oldHalo := self halo.
+ submorphs isEmpty ifTrue: [^ self delete].
+ aPosition := (owner submorphIndexOf: self) ifNil: [1].
+ unflexed := self firstSubmorph.
+ pensDown := OrderedCollection new.
+ self allMorphsDo: "Note any pens down -- must not be down during the move"
+ [:m | | player |
+ ((player := m player) notNil and: [player getPenDown]) ifTrue:
+ [m == player costume ifTrue:
+ [pensDown add: player.
+ player setPenDown: false]]].
+ self submorphs do: [:m |
+ m position: self center - (m extent // 2).
+ owner addMorph: m asElementNumber: aPosition].
+ unflexed absorbStateFromRenderer: self.
+ pensDown do: [:p | p setPenDown: true].
+ oldHalo ifNotNil: [oldHalo setTarget: unflexed].
+ myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: unflexed].
+ self delete.
+ unflexed referencePosition: refPos.
+ ^ unflexed!
Item was added:
+ ----- Method: TransformationMorph>>renderedMorph (in category 'classification') -----
+ renderedMorph
+ "We are a renderer. Answer appropriately."
+
+ submorphs isEmpty ifTrue: [^self].
+ ^self firstSubmorph renderedMorph!
Item was added:
+ ----- Method: TransformationMorph>>replaceSubmorph:by: (in category 'submorphs-add/remove') -----
+ replaceSubmorph: oldMorph by: newMorph
+ | t b |
+ t := transform.
+ b := bounds.
+ super replaceSubmorph: oldMorph by: newMorph.
+ transform := t.
+ bounds := b.
+ self layoutChanged!
Item was added:
+ ----- Method: TransformationMorph>>rotationDegrees (in category 'rotate scale and flex') -----
+ rotationDegrees
+ ^ self angle radiansToDegrees negated!
Item was added:
+ ----- Method: TransformationMorph>>rotationDegrees: (in category 'accessing') -----
+ rotationDegrees: degrees
+ self adjustAfter:[self angle: degrees degreesToRadians negated]!
Item was added:
+ ----- Method: TransformationMorph>>scaleFactor (in category 'accessing') -----
+ scaleFactor
+ "Answer the scaleFactor"
+
+ ^ transform scale!
Item was added:
+ ----- Method: TransformationMorph>>scaleToMatch: (in category 'accessing') -----
+ scaleToMatch: aPoint
+ | scaleFactor tfm originalScale |
+ tfm := transform withScale: 1.0.
+ originalScale := ((tfm localBoundsToGlobal: self renderedMorph fullBounds)
+ corner - (tfm localPointToGlobal: self renderedMorph referencePosition))
+ r.
+ "Catch cases where the reference point is on fullBounds corner"
+ originalScale := originalScale max: 1.0.
+ scaleFactor := (aPoint - self referencePosition) r / originalScale.
+ scaleFactor := scaleFactor < 1.0
+ ifTrue:
+ [scaleFactor
+ detentBy: 0.05
+ atMultiplesOf: 0.25
+ snap: false]
+ ifFalse:
+ [scaleFactor
+ detentBy: 0.1
+ atMultiplesOf: 0.5
+ snap: false].
+ self adjustAfter: [self scale: ((scaleFactor min: 8.0) max: 0.1)]!
Item was added:
+ ----- Method: TransformationMorph>>setDirectionFrom: (in category 'geometry eToy') -----
+ setDirectionFrom: aPoint
+ | delta degrees inner |
+ inner := self renderedMorph.
+ inner == self ifTrue:[^self].
+ delta := (inner transformFromWorld globalPointToLocal: aPoint) - inner referencePosition.
+ degrees := delta degrees + 90.0.
+ self forwardDirection: (degrees \\ 360) rounded.
+ !
Item was added:
+ ----- Method: TransformationMorph>>simplySetVisible: (in category 'geometry eToy') -----
+ simplySetVisible: aBoolean
+ "Set the receiver's visibility property. This mild circumlocution is because my own #visible: method would also set the visibility flag of my flexee, which in this case is pointless because it's the flexee that calls this."
+
+ super visible: aBoolean!
Item was added:
+ ----- Method: TransformationMorph>>stepTime (in category 'testing') -----
+ stepTime
+ "Answer the stepTime of my rendered morph if posible"
+
+ | rendered |
+ rendered := self renderedMorph.
+ rendered = self ifTrue: [^super stepTime]. "Hack to avoid infinite recursion"
+ ^rendered stepTime.
+ !
Item was added:
+ ----- Method: TransformationMorph>>transformedBy: (in category 'geometry') -----
+ transformedBy: aTransform
+ self changed.
+ self transform: (self transform composedWithGlobal: aTransform).
+ self computeBounds.
+ self changed.!
Item was added:
+ ----- Method: TransformationMorph>>visible: (in category 'geometry eToy') -----
+ visible: aBoolean
+ "Set the receiver's visibility property"
+
+ super visible: aBoolean.
+ submorphs isEmptyOrNil ifFalse: [submorphs first visible: aBoolean]!
Item was added:
+ Morph subclass: #TranslucentProgessMorph
+ instanceVariableNames: 'opaqueBackgroundColor'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
Item was added:
+ ----- Method: TranslucentProgessMorph>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ | revealPercentage revealingStyle revealingColor revealingBounds revealToggle x baseColor revealTimes secondsRemaining stringToDraw where fontToUse innerBounds |
+
+ innerBounds := bounds.
+ opaqueBackgroundColor ifNotNil: [
+ aCanvas
+ frameAndFillRectangle: bounds
+ fillColor: opaqueBackgroundColor
+ borderWidth: 8
+ borderColor: Color blue.
+ innerBounds := innerBounds insetBy: 8.
+ ].
+ revealTimes := (self valueOfProperty: #revealTimes) ifNil: [^self].
+ revealPercentage := (revealTimes first / revealTimes second) asFloat.
+ revealingStyle := self revealingStyle.
+ x := self valueOfProperty: #progressStageNumber ifAbsent: [1].
+ baseColor := Color perform: (#(red blue green magenta cyan yellow) atPin: x).
+ revealingColor := baseColor alpha: 0.2.
+ revealingStyle = 3 ifTrue: [ "wrap and change color"
+ revealPercentage > 1.0 ifTrue: [
+ revealingColor := baseColor alpha: (0.2 + (revealingStyle / 10) min: 0.5).
+ ].
+ revealPercentage := revealPercentage fractionPart.
+ ].
+ revealingStyle = 2 ifTrue: [ "peg at 75 and blink"
+ revealPercentage > 0.75 ifTrue: [
+ revealToggle := self valueOfProperty: #revealToggle ifAbsent: [true].
+ self setProperty: #revealToggle toValue: revealToggle not.
+ revealToggle ifTrue: [revealingColor := baseColor alpha: 0.8.].
+ ].
+ revealPercentage := revealPercentage min: 0.75.
+ ].
+ revealingBounds := innerBounds withLeft: innerBounds left + (innerBounds width * revealPercentage) truncated.
+ aCanvas
+ fillRectangle: revealingBounds
+ color: revealingColor.
+ secondsRemaining := (revealTimes second - revealTimes first / 1000) rounded.
+ secondsRemaining > 0 ifTrue: [
+ fontToUse := StrikeFont familyName: Preferences standardEToysFont familyName size: 24.
+ stringToDraw := secondsRemaining printString.
+ where := innerBounds corner - ((fontToUse widthOfString: stringToDraw) @ fontToUse height).
+ aCanvas
+ drawString: stringToDraw
+ in: (where corner: innerBounds corner)
+ font: fontToUse
+ color: Color black.
+ aCanvas
+ drawString: stringToDraw
+ in: (where - (1 at 1) corner: innerBounds corner)
+ font: fontToUse
+ color: Color white.
+ ].
+
+
+ !
Item was added:
+ ----- Method: TranslucentProgessMorph>>morphicLayerNumber (in category 'WiW support') -----
+ morphicLayerNumber
+
+ "helpful for insuring some morphs always appear in front of or behind others.
+ smaller numbers are in front"
+
+ ^self valueOfProperty: #morphicLayerNumber ifAbsent: [12].
+
+ "progress morphs are behind menus and balloons, but in front of most other stuff"!
Item was added:
+ ----- Method: TranslucentProgessMorph>>opaqueBackgroundColor: (in category 'as yet unclassified') -----
+ opaqueBackgroundColor: aColor
+
+ opaqueBackgroundColor := aColor!
Item was added:
+ ----- Method: TranslucentProgessMorph>>revealingStyle (in category 'as yet unclassified') -----
+ revealingStyle
+
+ ">>>>
+ 1 = original, no change after 100%
+ 2 = hold at last 25% and blink until done
+ 3 = wrap around from 100% back to 0 and go again. change color after first
+ <<<<"
+ ^3
+ !
Item was added:
+ MenuItemMorph subclass: #UpdatingMenuItemMorph
+ instanceVariableNames: 'wordingProvider wordingSelector enablementSelector wordingArgument'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus'!
+
+ !UpdatingMenuItemMorph commentStamp: '<historical>' prior: 0!
+ A menu item whose textual label and whose enablement are updatable. The wordingProvider provides the current wording, upon being being sent the wordingSelector.
+
+ The item can also dynamically update whether or not it should be enabled; to do this, give it an enablementSelector, which is also sent to the wordingProvider..!
Item was added:
+ ----- Method: UpdatingMenuItemMorph>>arrangeToStartSteppingIn: (in category 'stepping and presenter') -----
+ arrangeToStartSteppingIn: aWorld
+ super arrangeToStartSteppingIn: aWorld.
+ self updateContents.!
Item was added:
+ ----- Method: UpdatingMenuItemMorph>>enablement (in category 'enablement') -----
+ enablement
+
+ enablementSelector isBlock
+ ifTrue: [^ enablementSelector value]
+ ifFalse: [enablementSelector numArgs = 0
+ ifTrue: [^ wordingProvider perform: enablementSelector]
+ ifFalse: [^ wordingProvider perform: enablementSelector
+ withArguments: arguments]]!
Item was added:
+ ----- Method: UpdatingMenuItemMorph>>enablementSelector: (in category 'enablement') -----
+ enablementSelector: aSelector
+ enablementSelector := aSelector isBlock
+ ifTrue: [aSelector copyForSaving]
+ ifFalse: [aSelector] !
Item was added:
+ ----- Method: UpdatingMenuItemMorph>>step (in category 'stepping and presenter') -----
+ step
+ super step.
+ self updateContents.!
Item was added:
+ ----- Method: UpdatingMenuItemMorph>>stepTime (in category 'testing') -----
+ stepTime
+ ^ 1200!
Item was added:
+ ----- Method: UpdatingMenuItemMorph>>target: (in category 'wording') -----
+ target: anObject
+ "For us if the old target and wording provider are the same update both."
+ target = wordingProvider
+ ifTrue: [ wordingProvider := target := anObject ]
+ ifFalse: [ target := anObject ] .
+ !
Item was added:
+ ----- Method: UpdatingMenuItemMorph>>updateContents (in category 'world') -----
+ updateContents
+ "Update the receiver's contents"
+
+ | newString enablement nArgs |
+ ((wordingProvider isNil) or: [wordingSelector isNil]) ifFalse: [
+ nArgs := wordingSelector numArgs.
+ newString := nArgs = 0
+ ifTrue:
+ [wordingProvider perform: wordingSelector]
+ ifFalse:
+ [(nArgs = 1 and: [wordingArgument notNil])
+ ifTrue:
+ [wordingProvider perform: wordingSelector with: wordingArgument]
+ ifFalse:
+ [nArgs == arguments size ifTrue:
+ [wordingProvider perform: wordingSelector withArguments: arguments]]].
+ newString = (self contentString ifNil: [ contents ])
+ ifFalse: [self contents: newString.
+ MenuIcons decorateMenu: owner ]].
+ enablementSelector ifNotNil:
+ [(enablement := self enablement) == isEnabled
+ ifFalse: [self isEnabled: enablement]]!
Item was added:
+ ----- Method: UpdatingMenuItemMorph>>wordingArgument: (in category 'wording') -----
+ wordingArgument: anArgument
+ "Set the receiver's wordingArgument as indicated"
+
+ wordingArgument := anArgument!
Item was added:
+ ----- Method: UpdatingMenuItemMorph>>wordingProvider:wordingSelector: (in category 'wording') -----
+ wordingProvider: aProvider wordingSelector: aSelector
+ wordingProvider := aProvider.
+ wordingSelector := aSelector!
Item was added:
+ MenuMorph subclass: #UpdatingMenuMorph
+ instanceVariableNames: 'menuUpdater'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Menus'!
Item was added:
+ ----- Method: UpdatingMenuMorph>>activate: (in category 'as yet unclassified') -----
+ activate: evt
+ "Receiver should be activated; e.g., so that control passes correctly."
+
+ self updateMenu.
+ super activate: evt!
Item was added:
+ ----- Method: UpdatingMenuMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ menuUpdater := MenuUpdater new!
Item was added:
+ ----- Method: UpdatingMenuMorph>>updateMenu (in category 'update') -----
+ updateMenu
+
+ menuUpdater update: self!
Item was added:
+ ----- Method: UpdatingMenuMorph>>updater:updateSelector: (in category 'initialization') -----
+ updater: anObject updateSelector: aSelector
+
+ menuUpdater updater: anObject updateSelector: aSelector!
Item was added:
+ ----- Method: UpdatingMenuMorph>>updater:updateSelector:arguments: (in category 'initialization') -----
+ updater: anObject updateSelector: aSelector arguments: anArray
+
+ menuUpdater updater: anObject updateSelector: aSelector arguments: anArray!
Item was added:
+ SimpleButtonMorph subclass: #UpdatingSimpleButtonMorph
+ instanceVariableNames: 'wordingProvider wordingSelector'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !UpdatingSimpleButtonMorph commentStamp: '<historical>' prior: 0!
+ Adds to SimpleButtonMorph the ability to keep its own wording up to date by send a given message (indicated by its wordingSelector) to a given object (indicated by its wordingTarget, and normally the same as its target.)!
Item was added:
+ ----- Method: UpdatingSimpleButtonMorph>>step (in category 'stepping and presenter') -----
+ step
+ "If appropriate update the receiver's label"
+
+ | newString |
+ super step.
+ wordingProvider ifNotNil:
+ [newString := wordingProvider perform: wordingSelector.
+ newString = self label ifFalse: [self labelString: newString; changed]]!
Item was added:
+ ----- Method: UpdatingSimpleButtonMorph>>stepTime (in category 'testing') -----
+ stepTime
+ "Answer the desired time between steps in milliseconds. If the receiver has a wordingProvider that may dynamically provide changed wording for the label, step once every 1.5 seconds"
+
+ ^ wordingProvider ifNotNil: [1500] ifNil: [super stepTime]!
Item was added:
+ ----- Method: UpdatingSimpleButtonMorph>>wantsSteps (in category 'testing') -----
+ wantsSteps
+ "Answer whether the receiver wishes to be sent the #step message. In the current case, this decision depends on whether there is a wordingProvider which can dynamically provide fresh wording for the button's label"
+
+ ^ wordingProvider notNil!
Item was added:
+ ----- Method: UpdatingSimpleButtonMorph>>wordingSelector: (in category 'as yet unclassified') -----
+ wordingSelector: aSelector
+ wordingSelector := aSelector.
+ wordingProvider ifNil: [wordingProvider := target]!
Item was added:
+ StringMorph subclass: #UpdatingStringMorph
+ instanceVariableNames: 'format target lastValue getSelector putSelector floatPrecision growable stepTime autoAcceptOnFocusLoss minimumWidth maximumWidth'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
+
+ !UpdatingStringMorph commentStamp: '<historical>' prior: 0!
+ A StringMorph that constantly tries to show the current data from the target object. When sent #step, it shows what the target objects has (target perform: getSelector). When edited (with shift-click), it writes back to the target.
+
+ floatPrecision = 1. to round to integer.
+ floatPrecision = .1 to round to 1 decimal place, etc.
+
+ Even when ((target == nil) or: [getSelector == nil]), the user would still like to edit the string with shift-click.!
Item was added:
+ ----- Method: UpdatingStringMorph class>>on:selector: (in category 'instance creation') -----
+ on: targetObject selector: aSymbol
+
+ ^ self new
+ getSelector: aSymbol;
+ target: targetObject
+
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>acceptContents (in category 'editing') -----
+ acceptContents
+
+ self informTarget.
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>acceptValue: (in category 'editing') -----
+ acceptValue: aValue
+
+ self updateContentsFrom: (self acceptValueFromTarget: aValue).
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>acceptValueFromTarget: (in category 'target access') -----
+ acceptValueFromTarget: v
+ "Accept a value from the target"
+
+ lastValue := v.
+ self format == #string ifTrue: [^ v asString].
+ self format == #symbol ifTrue: [^ v asString translated].
+ (format == #default and: [v isNumber]) ifTrue:
+ [^ self stringForNumericValue: v].
+ ^ v printString translated!
Item was added:
+ ----- Method: UpdatingStringMorph>>addCustomMenuItems:hand: (in category 'editing') -----
+ addCustomMenuItems: menu hand: aHandMorph
+ | prefix |
+ super addCustomMenuItems: menu hand: aHandMorph.
+ prefix := (self growable
+ ifTrue: ['stop being growable']
+ ifFalse: ['start being growable']) translated.
+ menu add: prefix action: #toggleGrowability.
+ menu add: 'decimal places...' translated action: #setPrecision.
+ menu add: 'font size...' translated action: #setFontSize.
+ menu add: 'font style...' translated action: #setFontStyle!
Item was added:
+ ----- Method: UpdatingStringMorph>>autoAcceptOnFocusLoss (in category 'accessing') -----
+ autoAcceptOnFocusLoss
+ ^ autoAcceptOnFocusLoss ~~ false!
Item was added:
+ ----- Method: UpdatingStringMorph>>autoAcceptOnFocusLoss: (in category 'accessing') -----
+ autoAcceptOnFocusLoss: aBoolean
+ autoAcceptOnFocusLoss := aBoolean!
Item was added:
+ ----- Method: UpdatingStringMorph>>checkTarget (in category 'target access') -----
+ checkTarget
+ ""
+ getSelector ifNil: [^ true].
+ ^ getSelector numArgs = 0.
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>contents: (in category 'accessing') -----
+ contents: newContents
+ "This is the original StringMorph implementation of #contents:, restored down in UpdatingStringMorph because a recent 'optimization' of the StringMorph version of this method broke UpdatingStringMorphs."
+
+ contents := newContents isText
+ ifTrue:
+ [emphasis := newContents emphasisAt: 1.
+ newContents string]
+ ifFalse:
+ [contents = newContents ifTrue: [^self]. "no substantive change"
+ newContents].
+ self fitContents.
+ self changed!
Item was added:
+ ----- Method: UpdatingStringMorph>>decimalPlaces (in category 'accessing') -----
+ decimalPlaces
+ "Answer the number of decimal places to show."
+
+ | places |
+ (places := self valueOfProperty: #decimalPlaces) ifNotNil: [^ places].
+ self setProperty: #decimalPlaces toValue: (places := Utilities decimalPlacesForFloatPrecision: self floatPrecision).
+ ^ places!
Item was added:
+ ----- Method: UpdatingStringMorph>>decimalPlaces: (in category 'accessing') -----
+ decimalPlaces: aNumber
+ "Set the receiver's number of decimal places to be shown. If my target is a morph or a player, tell it about the change, in case it wants to remember it."
+
+ | constrained |
+ self setProperty: #decimalPlaces toValue: (constrained := aNumber min: 11).
+ self pvtFloatPrecision: (Utilities floatPrecisionForDecimalPlaces: constrained).
+ (target isMorph or:[target isPlayer]) ifTrue:
+ [target noteDecimalPlaces: constrained forGetter: getSelector]!
Item was added:
+ ----- Method: UpdatingStringMorph>>doneWithEdits (in category 'editing') -----
+ doneWithEdits
+ "If in a SyntaxMorph, shrink min width after editing"
+
+ | editor |
+ super doneWithEdits.
+ (owner respondsTo: #parseNode) ifTrue: [minimumWidth := 8].
+ editor := (submorphs detect: [ :sm | sm isKindOf: StringMorphEditor ] ifNone: [ ^self ]).
+ editor delete.!
Item was added:
+ ----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') -----
+ fitContents
+
+ | newExtent f |
+ f := self fontToUse.
+ newExtent := (((f widthOfString: contents) max: self minimumWidth) min: self maximumWidth) @ f height.
+ (self extent = newExtent) ifFalse:
+ [self extent: newExtent.
+ self changed]
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>floatPrecision (in category 'accessing') -----
+ floatPrecision
+ "Answer the floatPrecision to use:
+ 1.0 -> show whole number
+ 0.1 -> show one digit of precision
+ .01 -> show two digits of precision
+ etc.
+ Initialize the floatPrecision to 1 if it is not already defined"
+
+ floatPrecision isNumber ifFalse:
+ [self target: target]. "Fixes up errant cases from earlier bug"
+ ^ floatPrecision
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>format (in category 'accessing') -----
+ format
+ "Answer the receiver's format: #default or #string"
+
+ ^ format ifNil: [format := #default]!
Item was added:
+ ----- Method: UpdatingStringMorph>>getSelector (in category 'accessing') -----
+ getSelector
+
+ ^ getSelector
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>getSelector: (in category 'accessing') -----
+ getSelector: aSymbol
+
+ getSelector := aSymbol.
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>growable (in category 'accessing') -----
+ growable
+
+ ^ growable ~~ false
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>growable: (in category 'accessing') -----
+ growable: aBoolean
+
+ growable := aBoolean.
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>handlerForMouseDown: (in category 'events-processing') -----
+ handlerForMouseDown: evt
+ "Answer an object to field the mouseDown event provided, or nil if none"
+
+ | aHandler |
+ aHandler := super handlerForMouseDown: evt.
+ aHandler == self ifTrue: [^ self]. "I would get it anyways"
+ "Note: This is a hack to allow value editing in viewers"
+ ((owner wantsKeyboardFocusFor: self) and:
+ [self userEditsAllowed]) ifTrue: [^ self].
+ ^ aHandler!
Item was added:
+ ----- Method: UpdatingStringMorph>>handlesMouseDown: (in category 'event handling') -----
+ handlesMouseDown: evt
+ (owner wantsKeyboardFocusFor: self)
+ ifTrue:[^true].
+ ^ super handlesMouseDown: evt!
Item was added:
+ ----- Method: UpdatingStringMorph>>informTarget (in category 'target access') -----
+ informTarget
+ "Obtain a value from my contents, and tell my target about it. The putSelector can take one argument (traditional) or two (as used by Croquet)"
+
+ | newValue typeIn |
+ (target notNil and: [putSelector notNil])
+ ifTrue:
+ [typeIn := contents.
+ (newValue := self valueFromContents) ifNotNil:
+ [self checkTarget.
+ putSelector numArgs = 1
+ ifTrue: [target perform: putSelector with: newValue].
+ putSelector numArgs = 2
+ ifTrue:
+ [target
+ perform: putSelector
+ with: newValue
+ with: self].
+ target isMorph ifTrue: [target changed]].
+ self fitContents.
+ (format == #default and: [newValue isNumber])
+ ifTrue: [self setDecimalPlacesFromTypeIn: typeIn]]!
Item was added:
+ ----- Method: UpdatingStringMorph>>initialize (in category 'initialization') -----
+ initialize
+ "Initialie the receiver to have default values in its instance
+ variables "
+ super initialize.
+ ""
+ format := #default.
+ "formats: #string, #default"
+ target := getSelector := putSelector := nil.
+ floatPrecision := 1.
+ growable := true.
+ stepTime := 50.
+ autoAcceptOnFocusLoss := true.
+ minimumWidth := 8.
+ maximumWidth := 300!
Item was added:
+ ----- Method: UpdatingStringMorph>>isEtoyReadout (in category 'target access') -----
+ isEtoyReadout
+ "Answer whether the receiver can serve as an etoy readout"
+
+ ^ true!
Item was added:
+ ----- Method: UpdatingStringMorph>>lostFocusWithoutAccepting (in category 'editing') -----
+ lostFocusWithoutAccepting
+ "The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus -- typically by clicking on some editable text somewhere else -- without having accepted the current edits."
+
+ self autoAcceptOnFocusLoss ifTrue: [self doneWithEdits; acceptContents]!
Item was added:
+ ----- Method: UpdatingStringMorph>>maximumWidth (in category 'accessing') -----
+ maximumWidth
+ "Answer the maximum width that the receiver can have. A nil value means no maximum, and for practical purposes results in a value of 99999 here temporarily, for help in future debugging"
+
+ ^ maximumWidth ifNil: [99999]!
Item was added:
+ ----- Method: UpdatingStringMorph>>minimumWidth (in category 'accessing') -----
+ minimumWidth
+ "Answer the minimum width that the receiver can have. A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!! Obeyed by fitContents."
+
+ ^ minimumWidth ifNil: [minimumWidth := 8]!
Item was added:
+ ----- Method: UpdatingStringMorph>>minimumWidth: (in category 'accessing') -----
+ minimumWidth: aWidth
+ "Set the minimum width that the receiver can have. A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!! Obeyed by fitContents."
+
+ minimumWidth := aWidth!
Item was added:
+ ----- Method: UpdatingStringMorph>>mouseDown: (in category 'event handling') -----
+ mouseDown: evt
+ "The mouse went down over the receiver. If appropriate, launch a mini-editor so that the user can commence text-editing here"
+
+ (owner wantsKeyboardFocusFor: self) ifTrue:
+ [self userEditsAllowed ifTrue:
+ [(owner respondsTo: #parseNode)
+ ifTrue: "leave space for editing"
+ [minimumWidth := (49 max: minimumWidth)].
+ self launchMiniEditor: evt]]!
Item was added:
+ ----- Method: UpdatingStringMorph>>putSelector (in category 'accessing') -----
+ putSelector
+
+ ^ putSelector
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>putSelector: (in category 'accessing') -----
+ putSelector: aSymbol
+
+ putSelector := aSymbol.
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>pvtFloatPrecision: (in category 'accessing') -----
+ pvtFloatPrecision: aNumber
+ "Private - Set the floatPrecision instance variable to the given number"
+
+ floatPrecision := aNumber!
Item was added:
+ ----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') -----
+ readFromTarget
+ "Update my readout from my target"
+
+ | v ret |
+ (target isNil or: [getSelector isNil]) ifTrue: [^contents].
+ ret := self checkTarget.
+ ret ifFalse: [^ '0'].
+ v := target perform: getSelector. "scriptPerformer"
+ (v isKindOf: Text) ifTrue: [v := v asString].
+ ^self acceptValueFromTarget: v!
Item was added:
+ ----- Method: UpdatingStringMorph>>setDecimalPlaces: (in category 'editing') -----
+ setDecimalPlaces: places
+ "Set the number of decimal places, and update the display."
+
+ self decimalPlaces: places.
+ self acceptValueFromTarget: lastValue!
Item was added:
+ ----- Method: UpdatingStringMorph>>setDecimalPlacesFromTypeIn: (in category 'target access') -----
+ setDecimalPlacesFromTypeIn: typeIn
+ "The user has typed in a number as the new value of the receiver. Glean off decimal-places-preference from the type-in"
+
+ | decimalPointPosition tail places |
+ (typeIn includes: $e) ifTrue: [^ self].
+ decimalPointPosition := typeIn indexOf: $. ifAbsent: [nil].
+ places := 0.
+ decimalPointPosition
+ ifNotNil:
+ [tail := typeIn copyFrom: decimalPointPosition + 1 to: typeIn size.
+ [places < tail size and: [(tail at: (places + 1)) isDigit]]
+ whileTrue:
+ [places := places + 1]].
+
+ self decimalPlaces: places!
Item was added:
+ ----- Method: UpdatingStringMorph>>setFontSize (in category 'editing') -----
+ setFontSize
+ | sizes reply family |
+ family := font ifNil: [TextStyle default] ifNotNil: [font textStyle].
+ family ifNil: [family := TextStyle default]. "safety net -- this line SHOULD be unnecessary now"
+ sizes := family fontNamesWithPointSizes.
+ reply := UIManager default chooseFrom: sizes values: sizes.
+ reply ifNotNil:
+ [self font: (family fontAt: (sizes indexOf: reply))]!
Item was added:
+ ----- Method: UpdatingStringMorph>>setFontStyle (in category 'editing') -----
+ setFontStyle
+ | aList reply style |
+ aList := (TextConstants select: [:anItem | anItem isKindOf: TextStyle])
+ keys asArray.
+ reply := UIManager default chooseFrom: aList values: aList.
+ reply notNil
+ ifTrue:
+ [(style := TextStyle named: reply) ifNil:
+ [Beeper beep.
+ ^true].
+ self font: style defaultFont]!
Item was added:
+ ----- Method: UpdatingStringMorph>>setPrecision (in category 'editing') -----
+ setPrecision
+ "Allow the user to specify a number of decimal places. This UI is invoked from a menu. Nowadays the precision can be set by simple type-in, making this menu approach mostly obsolete. However, it's still useful for read-only readouts, where type-in is not allowed."
+
+ | aMenu |
+ aMenu := MenuMorph new.
+ aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
+ 0 to: 5 do:
+ [:places |
+ aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
+ aMenu popUpInWorld!
Item was added:
+ ----- Method: UpdatingStringMorph>>setToAllowTextEdit (in category 'editing') -----
+ setToAllowTextEdit
+ "Set up the receiver so that it will be receptive to text editing, even if there is no putSelector provided"
+
+ self setProperty: #okToTextEdit toValue: true!
Item was added:
+ ----- Method: UpdatingStringMorph>>step (in category 'stepping and presenter') -----
+ step
+ | s |
+ super step.
+ hasFocus ifFalse:
+ ["update contents, but only if user isn't editing this string"
+ s := self readFromTarget.
+ s = contents ifFalse:
+ [self updateContentsFrom: s]]
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>stepTime (in category 'testing') -----
+ stepTime
+
+ ^ stepTime ifNil: [50]
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>stepTime: (in category 'stepping') -----
+ stepTime: mSecsPerStep
+
+ stepTime := mSecsPerStep truncated.
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>stringForNumericValue: (in category 'target access') -----
+ stringForNumericValue: aValue
+ "Answer a suitably-formatted string representing the value."
+
+ | barePrintString |
+ ((barePrintString := aValue printString) includes: $e) ifTrue: [^ barePrintString].
+ ^ aValue printShowingDecimalPlaces: self decimalPlaces!
Item was added:
+ ----- Method: UpdatingStringMorph>>target (in category 'accessing') -----
+ target
+
+ ^ target
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>target: (in category 'accessing') -----
+ target: anObject
+
+ target := anObject.
+ getSelector ifNotNil: [floatPrecision := anObject defaultFloatPrecisionFor: getSelector]
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>toggleGrowability (in category 'editing') -----
+ toggleGrowability
+ growable := self growable not.
+ self updateContentsFrom: self readFromTarget.
+ growable ifTrue: [self fitContents]!
Item was added:
+ ----- Method: UpdatingStringMorph>>updateContentsFrom: (in category 'stepping') -----
+ updateContentsFrom: aValue
+ self growable
+ ifTrue:
+ [self contents: aValue]
+ ifFalse:
+ [self contentsClipped: aValue]!
Item was added:
+ ----- Method: UpdatingStringMorph>>useDefaultFormat (in category 'formats') -----
+ useDefaultFormat
+ "Use the object's own printString format."
+
+ format := #default.
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>useStringFormat (in category 'formats') -----
+ useStringFormat
+
+ format := #string.!
Item was added:
+ ----- Method: UpdatingStringMorph>>useSymbolFormat (in category 'formats') -----
+ useSymbolFormat
+
+ format := #symbol.!
Item was added:
+ ----- Method: UpdatingStringMorph>>userEditsAllowed (in category 'editing') -----
+ userEditsAllowed
+ "Answer whether user-edits are allowed to this field"
+
+ ^ putSelector notNil or: [self hasProperty: #okToTextEdit]!
Item was added:
+ ----- Method: UpdatingStringMorph>>valueFromContents (in category 'accessing') -----
+ valueFromContents
+ "Return a new value from the current contents string."
+
+ "
+ | expression tilePadMorphOrNil asNumberBlock |
+ asNumberBlock := [:string | [string asNumber]
+ on: Error
+ do: []].
+ format = #string
+ ifTrue: [^ contents].
+ (format = #default
+ and: [self owner isKindOf: NumericReadoutTile])
+ ifTrue: [^ asNumberBlock value: contents].
+ tilePadMorphOrNil := self ownerThatIsA: TilePadMorph.
+ (tilePadMorphOrNil notNil
+ and: [tilePadMorphOrNil type = #Number])
+ ifTrue: [^ asNumberBlock value: contents].
+ expression := Vocabulary eToyVocabulary translationKeyFor: contents.
+ expression isNil
+ ifTrue: [expression := contents].
+ ^ Compiler evaluate: expression
+ "
+
+ format = #symbol ifTrue: [^ lastValue].
+ format = #string ifTrue: [^ contents].
+ (owner notNil and: [owner isNumericReadoutTile]) ifTrue: [
+ ^ Number readFrom: contents
+ ].
+ target ifNotNil: [target owner ifNotNil: [
+ ((target owner isTilePadMorph) and: [target owner type = #Number])
+ ifTrue: [^ Number readFrom: contents]]].
+ ^ Compiler evaluate: contents
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>veryDeepFixupWith: (in category 'copying') -----
+ veryDeepFixupWith: deepCopier
+ "If target field is weakly copied, fix it here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"
+
+ super veryDeepFixupWith: deepCopier.
+ target := deepCopier references at: target ifAbsent: [target].
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
+ "Copy all of my instance variables. Some need to be not copied at all, but shared."
+
+ super veryDeepInner: deepCopier.
+ format := format veryDeepCopyWith: deepCopier.
+ target := target. "Weakly copied"
+ lastValue := lastValue veryDeepCopyWith: deepCopier.
+ getSelector := getSelector. "Symbol"
+ putSelector := putSelector. "Symbol"
+ floatPrecision := floatPrecision veryDeepCopyWith: deepCopier.
+ growable := growable veryDeepCopyWith: deepCopier.
+ stepTime := stepTime veryDeepCopyWith: deepCopier.
+ autoAcceptOnFocusLoss := autoAcceptOnFocusLoss veryDeepCopyWith: deepCopier.
+ minimumWidth := minimumWidth veryDeepCopyWith: deepCopier.
+ maximumWidth := maximumWidth veryDeepCopyWith: deepCopier.
+ !
Item was added:
+ ----- Method: UpdatingStringMorph>>wouldAcceptKeyboardFocus (in category 'event handling') -----
+ wouldAcceptKeyboardFocus
+ ^ (self hasProperty: #okToTextEdit) or: [super wouldAcceptKeyboardFocus]!
Item was added:
+ ThreePhaseButtonMorph subclass: #UpdatingThreePhaseButtonMorph
+ instanceVariableNames: 'getSelector getArgument'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Widgets'!
Item was added:
+ ----- Method: UpdatingThreePhaseButtonMorph>>doButtonAction (in category 'button') -----
+ doButtonAction
+ "Since the action likely changes our state, do a step so we're updated immediately"
+ super doButtonAction.
+ self step
+ !
Item was added:
+ ----- Method: UpdatingThreePhaseButtonMorph>>getSelector: (in category 'as yet unclassified') -----
+ getSelector: sel
+ getSelector := sel!
Item was added:
+ ----- Method: UpdatingThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
+ "Since mouseUp likely changes our state, do a step so we're updated immediately"
+ super mouseUp: evt.
+ self step!
Item was added:
+ ----- Method: UpdatingThreePhaseButtonMorph>>step (in category 'stepping and presenter') -----
+ step
+ | newBoolean |
+ super step.
+ state == #pressed ifTrue: [^ self].
+ newBoolean := target perform: getSelector.
+ newBoolean == self isOn
+ ifFalse:
+ [self state: (newBoolean == true ifTrue: [#on] ifFalse: [#off])]!
Item was added:
+ ----- Method: UpdatingThreePhaseButtonMorph>>wantsSteps (in category 'testing') -----
+ wantsSteps
+ ^ true!
Item was added:
+ AlignmentMorph subclass: #UserDialogBoxMorph
+ instanceVariableNames: 'titleMorph labelMorph buttonRow value selectedButton cancelButton timeout savedLabel keyMap'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Windows'!
+
+ !UserDialogBoxMorph commentStamp: 'ar 12/11/2009 22:33' prior: 0!
+ A DialogBoxMorph is Morph used in simple yes/no/confirm dialogs. Strongly modal.!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm: (in category 'utilities') -----
+ confirm: aString
+ "UserDialogBoxMorph confirm: 'Do you like chocolate?'"
+ ^self confirm: aString title: 'Please confirm:'!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm:orCancel: (in category 'utilities') -----
+ confirm: aString orCancel: cancelBlock
+ "UserDialogBoxMorph confirm: 'Do you like chocolate?'"
+ ^self confirm: aString orCancel: cancelBlock at: nil!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm:orCancel:at: (in category 'utilities') -----
+ confirm: aString orCancel: cancelBlock at: aPointOrNil
+ ^self
+ confirm: aString
+ orCancel: cancelBlock
+ title: 'Please confirm:'
+ at: aPointOrNil!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm:orCancel:title:at: (in category 'utilities') -----
+ confirm: aString orCancel: cancelBlock title: titleString at: aPointOrNil
+
+ ^(self new
+ title: titleString;
+ label: aString;
+ addSelectedButton: ' Yes ' translated value: true;
+ addButton: ' No ' translated value: false;
+ addCancelButton: ' Cancel ' translated value: nil;
+ runModalIn: ActiveWorld forHand: ActiveHand at: aPointOrNil)
+ ifNil: [ cancelBlock value ]!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm:title: (in category 'utilities') -----
+ confirm: aString title: titleString
+ "UserDialogBoxMorph confirm: 'Make your choice carefully' withCRs title: 'Do you like chocolate?'"
+ ^self confirm: aString title: titleString at: nil!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm:title:at: (in category 'utilities') -----
+ confirm: aString title: titleString at: aPointOrNil
+ "UserDialogBoxMorph confirm: 'Make your choice carefully' withCRs title: 'Do you like chocolate?'"
+ ^self new
+ title: titleString;
+ label: aString;
+ addSelectedButton: ' Yes ' translated value: true;
+ addCancelButton: ' No ' translated value: false;
+ runModalIn: ActiveWorld forHand: ActiveHand at: aPointOrNil!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm:title:trueChoice:falseChoice: (in category 'utilities') -----
+ confirm: aString title: titleString trueChoice: trueChoice falseChoice: falseChoice
+ "UserDialogBoxMorph confirm: 'Make your choice carefully' withCRs title: 'Do you like chocolate?' trueChoice: 'Oh yessir!!' falseChoice: 'Not so much...' "
+ ^self confirm: aString title: titleString trueChoice: trueChoice falseChoice: falseChoice at: nil!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm:title:trueChoice:falseChoice:at: (in category 'utilities') -----
+ confirm: aString title: titleString trueChoice: trueChoice falseChoice: falseChoice at: aPointOrNil
+ "UserDialogBoxMorph confirm: 'Make your choice carefully' withCRs title: 'Do you like chocolate?' trueChoice: 'Oh yessir!!' falseChoice: 'Not so much...'"
+ ^self new
+ title: titleString;
+ label: aString;
+ addSelectedButton: ' ', trueChoice translated, ' ' value: true;
+ addCancelButton: ' ', falseChoice translated, ' ' value: false;
+ runModalIn: ActiveWorld forHand: ActiveHand at: aPointOrNil!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm:title:trueChoice:falseChoice:default:triggerAfter:at: (in category 'utilities') -----
+ confirm: aString title: titleString trueChoice: trueChoice falseChoice: falseChoice default: default triggerAfter: seconds at: aPointOrNil
+ "UserDialogBoxMorph confirm: 'I like hot java' title: 'What do you say?' trueChoice: 'You bet!!' falseChoice: 'Nope' default: false triggerAfter: 12 at: 121 at 212"
+ ^self new
+ title: titleString;
+ label: aString;
+ addButton: ' ', trueChoice translated, ' ' value: true selected: default performActionOnEscape: false;
+ addButton: ' ', falseChoice translated, ' ' value: false selected: default not performActionOnEscape: true;
+ triggerAfter: seconds;
+ runModalIn: ActiveWorld forHand: ActiveHand at: aPointOrNil!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>confirm:trueChoice:falseChoice: (in category 'utilities') -----
+ confirm: aString trueChoice: trueChoice falseChoice: falseChoice
+ "UserDialogBoxMorph confirm: 'Do you like chocolate?' trueChoice: 'Oh yessir!!' falseChoice: 'Not so much...' "
+ ^self confirm: aString title: 'Please confirm:' trueChoice: trueChoice falseChoice: falseChoice at: nil!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>inform: (in category 'utilities') -----
+ inform: aString
+ "UserDialogBoxMorph inform: 'Squeak is great!!'"
+ ^self inform: aString title: 'Note:'!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>inform:title: (in category 'utilities') -----
+ inform: aString title: titleString
+ "UserDialogBoxMorph inform: 'Squeak is great!!' title: 'Will you look at this:'"
+ ^self inform: aString title: titleString at: nil!
Item was added:
+ ----- Method: UserDialogBoxMorph class>>inform:title:at: (in category 'utilities') -----
+ inform: aString title: titleString at: aPointOrNil
+ "UserDialogBoxMorph inform: 'Squeak is great!!' title: 'Will you look at this:'"
+
+ ^self new
+ title: titleString;
+ label: aString;
+ addSelectedCancelButton: ' OK ' translated value: nil;
+ runModalIn: ActiveWorld forHand: ActiveHand at: aPointOrNil!
Item was added:
+ ----- Method: UserDialogBoxMorph>>addButton:value: (in category 'constructing') -----
+ addButton: buttonLabel value: buttonValue
+
+ self
+ addButton: buttonLabel
+ value: buttonValue
+ selected: false
+ performActionOnEscape: false!
Item was added:
+ ----- Method: UserDialogBoxMorph>>addButton:value:selected:performActionOnEscape: (in category 'constructing') -----
+ addButton: buttonLabel value: buttonValue selected: isSelected performActionOnEscape: performActionOnEscape
+ "Adds a button with the given label and value.
+ The value is returned if the user presses the button."
+ | button |
+ button := PluggableButtonMorphPlus new
+ label: buttonLabel ;
+ action: [ self closeDialog: buttonValue ] ;
+ color: self buttonColor twiceLighter.
+ isSelected ifTrue: [ self selectButton: button ].
+ performActionOnEscape ifTrue: [ self performActionOnEscapeOf: button ].
+ self registerKeyFor: button.
+ buttonRow addMorphBack: button!
Item was added:
+ ----- Method: UserDialogBoxMorph>>addCancelButton:value: (in category 'constructing') -----
+ addCancelButton: buttonLabel value: buttonValue
+
+ self
+ addButton: buttonLabel
+ value: buttonValue
+ selected: false
+ performActionOnEscape: true!
Item was added:
+ ----- Method: UserDialogBoxMorph>>addSelectedButton:value: (in category 'constructing') -----
+ addSelectedButton: buttonLabel value: buttonValue
+
+ self
+ addButton: buttonLabel
+ value: buttonValue
+ selected: true
+ performActionOnEscape: false!
Item was added:
+ ----- Method: UserDialogBoxMorph>>addSelectedCancelButton:value: (in category 'constructing') -----
+ addSelectedCancelButton: buttonLabel value: buttonValue
+
+ self
+ addButton: buttonLabel
+ value: buttonValue
+ selected: true
+ performActionOnEscape: true!
Item was added:
+ ----- Method: UserDialogBoxMorph>>buttonColor (in category 'initialization') -----
+ buttonColor
+ ^Color r: 0.658 g: 0.678 b: 0.78!
Item was added:
+ ----- Method: UserDialogBoxMorph>>buttons (in category 'events') -----
+ buttons
+
+ ^buttonRow submorphs select: [ :each |
+ each isKindOf: PluggableButtonMorphPlus ].!
Item was added:
+ ----- Method: UserDialogBoxMorph>>checkAgainstKeymap: (in category 'events') -----
+ checkAgainstKeymap: aCharacter
+ keyMap
+ at: aCharacter asLowercase
+ ifPresent: [ : foundButton | foundButton performAction ]
+ ifAbsent: [ "do nothing" ]!
Item was added:
+ ----- Method: UserDialogBoxMorph>>closeDialog: (in category 'running') -----
+ closeDialog: returnValue
+ value := returnValue.
+ self delete.!
Item was added:
+ ----- Method: UserDialogBoxMorph>>deselectSelectedButton (in category 'events') -----
+ deselectSelectedButton
+
+ selectedButton ifNil: [ ^self ].
+ selectedButton color: self buttonColor twiceLighter.
+ selectedButton := nil!
Item was added:
+ ----- Method: UserDialogBoxMorph>>drawSubmorphsOn: (in category 'drawing') -----
+ drawSubmorphsOn: aCanvas
+
+ super drawSubmorphsOn: aCanvas.
+
+ self wantsRoundedCorners ifTrue: [
+ "Overdraw lower part of title bar to hide bottom corners."
+ aCanvas
+ fillRectangle: (self submorphs first "titleRow" bottomLeft - (-1 @ Morph preferredCornerRadius)
+ corner: self submorphs first "titleRow" bottomRight - (1 at 0))
+ color: self color].!
Item was added:
+ ----- Method: UserDialogBoxMorph>>flash (in category 'events') -----
+ flash
+ "Flash me"
+ 1 to: 2 do:[:i|
+ self color: Color black.
+ self world doOneCycleNow.
+ (Delay forMilliseconds: 50) wait.
+ self color: Color white.
+ self world doOneCycleNow.
+ (Delay forMilliseconds: 50) wait.
+ ].!
Item was added:
+ ----- Method: UserDialogBoxMorph>>handleFocusEvent: (in category 'constructing') -----
+ handleFocusEvent: evt
+ "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children."
+ self processEvent: evt.
+
+ "Need to handle keyboard input if we have the focus."
+ ^self handleEvent: evt!
Item was added:
+ ----- Method: UserDialogBoxMorph>>handlesKeyboard: (in category 'events') -----
+ handlesKeyboard: evt
+
+ ^true!
Item was added:
+ ----- Method: UserDialogBoxMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ | titleRow cc |
+ super initialize.
+ self color: Color white.
+ self listDirection: #topToBottom; wrapCentering: #center;
+ hResizing: #shrinkWrap; vResizing: #shrinkWrap.
+ self layoutInset: -1 @ -1; cellInset: 5 at 5.
+ self borderStyle: BorderStyle thinGray.
+ self useRoundedCorners.
+ self hasDropShadow: true.
+ self useSoftDropShadow
+ ifFalse: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666);
+ shadowOffset: 1 @ 1]
+ ifTrue: [
+ self
+ shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.01);
+ shadowOffset: (10 at 8 corner: 10 at 12)].
+
+ cc := Color gray: 0.8.
+ titleRow := AlignmentMorph newRow.
+ titleRow hResizing: #spaceFill; vResizing: #shrinkWrap.
+ titleRow useRoundedCorners.
+ titleRow borderStyle: BorderStyle thinGray.
+ titleRow layoutInset: (2 at 5 corner: (2@ (5 + Morph preferredCornerRadius))).
+ titleRow color: cc.
+ titleRow fillStyle: self titleGradient.
+
+ titleMorph := StringMorph new.
+ titleMorph emphasis: 1.
+ titleRow addMorph: titleMorph.
+ labelMorph := TextMorph new.
+ labelMorph margins: 5 at 5.
+ labelMorph lock.
+ buttonRow := AlignmentMorph newRow vResizing: #shrinkWrap.
+ buttonRow hResizing: #shrinkWrap; layoutInset: 5 at 5; cellInset: 5 at 5.
+ buttonRow color: Color transparent.
+ self
+ addMorphBack: titleRow ;
+ addMorphBack: labelMorph ;
+ addMorphBack: buttonRow.
+ keyMap := Dictionary new!
Item was added:
+ ----- Method: UserDialogBoxMorph>>justDroppedInto:event: (in category 'events') -----
+ justDroppedInto: aMorph event: event
+ "aggressively preserve focus"
+ event hand newMouseFocus: self.!
Item was added:
+ ----- Method: UserDialogBoxMorph>>keyStroke: (in category 'events') -----
+ keyStroke: evt
+ | evtCharacter |
+ self stopAutoTrigger.
+ evtCharacter := evt keyCharacter.
+ evtCharacter = Character escape ifTrue: [
+ ^cancelButton ifNotNil: [ cancelButton performAction ] ].
+ evtCharacter = Character cr ifTrue: [
+ ^selectedButton ifNotNil: [ selectedButton performAction ] ].
+ (evtCharacter = Character arrowLeft or: [
+ evt shiftPressed and: [ evtCharacter = Character tab ] ]) ifTrue: [
+ ^self selectPreviousButton ].
+ (evtCharacter = Character arrowRight or: [
+ evtCharacter = Character tab ]) ifTrue: [
+ ^self selectNextButton ].
+ self checkAgainstKeymap: evtCharacter!
Item was added:
+ ----- Method: UserDialogBoxMorph>>label (in category 'constructing') -----
+ label
+ "The dialog's label (String)"
+ ^labelMorph contents
+ !
Item was added:
+ ----- Method: UserDialogBoxMorph>>label: (in category 'constructing') -----
+ label: aString
+ "The dialog's label (String)"
+ labelMorph contents: aString.
+ !
Item was added:
+ ----- Method: UserDialogBoxMorph>>mouseDown: (in category 'events') -----
+ mouseDown: event
+ self stopAutoTrigger.
+ "Always bring me to the front since I am modal"
+ self comeToFront.
+ (self containsPoint: event position) ifFalse:[
+ Beeper beepPrimitive.
+ ^self flash].
+ event hand grabMorph: self.!
Item was added:
+ ----- Method: UserDialogBoxMorph>>mouseUp: (in category 'events') -----
+ mouseUp: event
+ self stopAutoTrigger.
+ "aggressively preserve focus"
+ event hand newMouseFocus: self.!
Item was added:
+ ----- Method: UserDialogBoxMorph>>performActionOnEscapeOf: (in category 'constructing') -----
+ performActionOnEscapeOf: aButton
+
+ cancelButton := aButton!
Item was added:
+ ----- Method: UserDialogBoxMorph>>registerKeyFor: (in category 'constructing') -----
+ registerKeyFor: button
+ button label do:
+ [ : eachChar | eachChar isAlphaNumeric ifTrue:
+ [ keyMap
+ at: eachChar asLowercase
+ ifPresent: [ : found | "It's already taken, don't use it." ]
+ ifAbsent:
+ [ ^ keyMap
+ at: eachChar asLowercase
+ put: button ] ] ]!
Item was added:
+ ----- Method: UserDialogBoxMorph>>runModalIn:forHand:at: (in category 'running') -----
+ runModalIn: aWorld forHand: aHand at: aPointOrNil
+ "Ensure that we have a reasonable minimum size"
+ | oldFocus pos offset |
+ (ProvideAnswerNotification signal: self label asString) ifNotNil:[:answer| ^answer].
+ self openInWorld: aWorld.
+ pos := aPointOrNil ifNil: [aHand position].
+ offset := aPointOrNil
+ ifNil: [selectedButton fullBounds origin - (selectedButton fullBounds extent // 2 * (-1 at 1))]
+ ifNotNil: [self fullBounds extent // 2].
+ self setConstrainedPosition: pos - offset hangOut: false.
+ oldFocus := aHand keyboardFocus.
+ aHand newMouseFocus: self.
+ aHand newKeyboardFocus: self.
+ savedLabel := selectedButton label.
+ [self isInWorld] whileTrue:[aWorld doOneSubCycle].
+ oldFocus ifNotNil:[aHand keyboardFocus: oldFocus].
+ ^value!
Item was added:
+ ----- Method: UserDialogBoxMorph>>selectButton: (in category 'events') -----
+ selectButton: aButton
+
+ self deselectSelectedButton.
+ aButton color: Color orange muchLighter.
+ selectedButton := aButton!
Item was added:
+ ----- Method: UserDialogBoxMorph>>selectNextButton (in category 'events') -----
+ selectNextButton
+
+ | buttons |
+ buttons := self buttons.
+ self selectButton: (buttons atWrap: (buttons indexOf: selectedButton) + 1)!
Item was added:
+ ----- Method: UserDialogBoxMorph>>selectPreviousButton (in category 'events') -----
+ selectPreviousButton
+
+ | buttons |
+ buttons := self buttons.
+ self selectButton: (buttons atWrap: (buttons indexOf: selectedButton) - 1)!
Item was added:
+ ----- Method: UserDialogBoxMorph>>step (in category 'stepping and presenter') -----
+ step
+ timeout ifNil: [^self].
+ timeout = 0
+ ifTrue: [
+ self stopStepping.
+ selectedButton performAction]
+ ifFalse: [
+ selectedButton label: savedLabel, '(', timeout printString, ')'.
+ timeout := timeout - 1]!
Item was added:
+ ----- Method: UserDialogBoxMorph>>stepTime (in category 'stepping and presenter') -----
+ stepTime
+ ^1000!
Item was added:
+ ----- Method: UserDialogBoxMorph>>stopAutoTrigger (in category 'stepping and presenter') -----
+ stopAutoTrigger
+ timeout ifNil: [^self].
+ timeout := nil.
+ self stopStepping.
+ selectedButton label: savedLabel !
Item was added:
+ ----- Method: UserDialogBoxMorph>>title (in category 'constructing') -----
+ title
+ ^titleMorph contents!
Item was added:
+ ----- Method: UserDialogBoxMorph>>title: (in category 'constructing') -----
+ title: aString
+ titleMorph contents: aString!
Item was added:
+ ----- Method: UserDialogBoxMorph>>titleGradient (in category 'initialization') -----
+ titleGradient
+
+ | cc gradient |
+ SystemWindow gradientWindow
+ ifFalse: [^ SolidFillStyle color: self buttonColor].
+
+ cc := self buttonColor.
+ gradient := GradientFillStyle ramp: {
+ 0.0 -> Color white.
+ 0.33 ->(cc mixed: 0.5 with: Color white).
+ 1.0 -> cc.
+ }.
+ gradient origin: 0 at 0.
+ gradient direction: 0 @ (TextStyle defaultFont height + 10).
+ ^gradient!
Item was added:
+ ----- Method: UserDialogBoxMorph>>triggerAfter: (in category 'constructing') -----
+ triggerAfter: seconds
+ timeout := seconds!
Item was added:
+ ----- Method: UserDialogBoxMorph>>wantsToBeDroppedInto: (in category 'events') -----
+ wantsToBeDroppedInto: aMorph
+ "Return true if it's okay to drop the receiver into aMorph"
+ ^aMorph isWorldMorph "only into worlds"!
Item was added:
+ MorphicEvent subclass: #UserInputEvent
+ instanceVariableNames: 'type buttons position handler wasHandled'
+ classVariableNames: ''
+ poolDictionaries: 'EventSensorConstants'
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: UserInputEvent>>anyModifierKeyPressed (in category 'modifier state') -----
+ anyModifierKeyPressed
+ "ignore, however, the shift keys 'cause that's not REALLY a command key "
+
+ ^ self buttons anyMask: 16r70 "cmd | opt | ctrl"!
Item was added:
+ ----- Method: UserInputEvent>>buttonString (in category 'printing') -----
+ buttonString
+ "Return a string identifying the currently pressed buttons"
+ | string |
+ string := ''.
+ self redButtonPressed ifTrue:[string := string,'red '].
+ self yellowButtonPressed ifTrue:[string := string,'yellow '].
+ self blueButtonPressed ifTrue:[string := string,'blue '].
+ ^string!
Item was added:
+ ----- Method: UserInputEvent>>buttons (in category 'accessing') -----
+ buttons
+ "Return the a word encoding the mouse and modifier buttons for this event."
+
+ ^ buttons!
Item was added:
+ ----- Method: UserInputEvent>>commandKeyPressed (in category 'modifier state') -----
+ commandKeyPressed
+ "Answer true if the command key on the keyboard was being held down when this event occurred."
+
+ ^ buttons anyMask: 64!
Item was added:
+ ----- Method: UserInputEvent>>controlKeyPressed (in category 'modifier state') -----
+ controlKeyPressed
+ "Answer true if the control key on the keyboard was being held down when this event occurred."
+
+ ^ buttons anyMask: 16!
Item was added:
+ ----- Method: UserInputEvent>>copyHandlerState: (in category 'initialize') -----
+ copyHandlerState: anEvent
+ "Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
+ handler := anEvent handler.
+ wasHandled := anEvent wasHandled.!
Item was added:
+ ----- Method: UserInputEvent>>handler (in category 'accessing') -----
+ handler
+ ^handler!
Item was added:
+ ----- Method: UserInputEvent>>handler: (in category 'accessing') -----
+ handler: anObject
+ handler := anObject!
Item was added:
+ ----- Method: UserInputEvent>>modifierString (in category 'printing') -----
+ modifierString
+ "Return a string identifying the currently pressed modifiers"
+ | string |
+ string := ''.
+ self commandKeyPressed ifTrue:[string := string,'CMD '].
+ self shiftPressed ifTrue:[string := string,'SHIFT '].
+ self controlKeyPressed ifTrue:[string := string,'CTRL '].
+ ^string!
Item was added:
+ ----- Method: UserInputEvent>>position (in category 'accessing') -----
+ position
+ ^position!
Item was added:
+ ----- Method: UserInputEvent>>resetHandlerFields (in category 'initialize') -----
+ resetHandlerFields
+ "Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"
+ handler := nil.
+ wasHandled := false.!
Item was added:
+ ----- Method: UserInputEvent>>setPosition: (in category 'private') -----
+ setPosition: aPoint
+ position := aPoint!
Item was added:
+ ----- Method: UserInputEvent>>shiftPressed (in category 'modifier state') -----
+ shiftPressed
+ "Answer true if the shift key on the keyboard was being held down when this event occurred."
+
+ ^ buttons anyMask: 8
+ !
Item was added:
+ ----- Method: UserInputEvent>>transformBy: (in category 'transforming') -----
+ transformBy: aMorphicTransform
+ "Transform the receiver into a local coordinate system."
+ position := aMorphicTransform globalPointToLocal: position.!
Item was added:
+ ----- Method: UserInputEvent>>transformedBy: (in category 'transforming') -----
+ transformedBy: aMorphicTransform
+ "Return the receiver transformed by the given transform into a local coordinate system."
+ ^self shallowCopy transformBy: aMorphicTransform!
Item was added:
+ ----- Method: UserInputEvent>>translateBy: (in category 'transforming') -----
+ translateBy: delta
+ "add delta to cursorPoint, and return the new event"
+ position := position + delta.!
Item was added:
+ ----- Method: UserInputEvent>>translatedBy: (in category 'transforming') -----
+ translatedBy: delta
+ "add delta to cursorPoint, and return the new event"
+ ^self shallowCopy translateBy: delta!
Item was added:
+ ----- Method: UserInputEvent>>type (in category 'accessing') -----
+ type
+ "Return a symbol indicating the type this event."
+
+ ^ type!
Item was added:
+ ----- Method: UserInputEvent>>wasHandled (in category 'accessing') -----
+ wasHandled
+ ^wasHandled!
Item was added:
+ ----- Method: UserInputEvent>>wasHandled: (in category 'accessing') -----
+ wasHandled: aBool
+ wasHandled := aBool.!
Item was added:
+ MorphicEvent subclass: #WindowEvent
+ instanceVariableNames: 'action rectangle'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
+
+ !WindowEvent commentStamp: '<historical>' prior: 0!
+ I'm an event related to the host window, only dispatched to the World. !
Item was added:
+ ----- Method: WindowEvent>>action (in category 'accessing') -----
+ action
+ ^action!
Item was added:
+ ----- Method: WindowEvent>>action: (in category 'accessing') -----
+ action: aValue
+ action := aValue.!
Item was added:
+ ----- Method: WindowEvent>>isWindowEvent (in category 'testing') -----
+ isWindowEvent
+ ^true!
Item was added:
+ ----- Method: WindowEvent>>printOn: (in category 'printing') -----
+ printOn: aStream
+
+ aStream nextPut: $[.
+ aStream nextPutAll: self type; space.
+ aStream nextPut: $(; print: self rectangle; nextPut: $).
+ aStream nextPut: $].!
Item was added:
+ ----- Method: WindowEvent>>rectangle (in category 'accessing') -----
+ rectangle
+ ^rectangle!
Item was added:
+ ----- Method: WindowEvent>>rectangle: (in category 'accessing') -----
+ rectangle: aValue
+ rectangle := aValue.!
Item was added:
+ ----- Method: WindowEvent>>sentTo: (in category 'dispatching') -----
+ sentTo:anObject
+ "Dispatch the receiver into anObject"
+ ^anObject handleWindowEvent: self.!
Item was added:
+ ----- Method: WindowEvent>>type (in category 'accessing') -----
+ type
+ "This should match the definitions in sq.h"
+ ^#(
+ windowMetricChange
+ windowClose
+ windowIconise
+ windowActivated
+ windowPaint
+ ) at: action ifAbsent: [#windowEventUnknown]!
Item was added:
+ Object subclass: #WorldState
+ instanceVariableNames: 'hands activeHand viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime commandHistory alarms lastAlarmTime remoteServer multiCanvas interCycleDelay'
+ classVariableNames: 'CanSurrenderToOS DeferredUIMessages DisableDeferredUpdates LastCycleTime MinCycleLapse'
+ poolDictionaries: ''
+ category: 'Morphic-Worlds'!
+
+ !WorldState commentStamp: 'ls 7/10/2003 19:30' prior: 0!
+ The state of a Morphic world. (This needs some serious commenting!!!!)
+
+
+ The MinCycleLapse variable holds the minimum amount of time that a morphic cycle is allowed to take. If a cycle takes less than this, then interCyclePause: will wait until the full time has been used up.!
Item was added:
+ ----- Method: WorldState class>>addDeferredUIMessage: (in category 'class initialization') -----
+ addDeferredUIMessage: valuableObject
+
+ self deferredUIMessages nextPut: valuableObject.
+
+ !
Item was added:
+ ----- Method: WorldState class>>canSurrenderToOS: (in category 'as yet unclassified') -----
+ canSurrenderToOS: aBoolean
+
+ CanSurrenderToOS := aBoolean!
Item was added:
+ ----- Method: WorldState class>>classVersion (in category 'objects from disk') -----
+ classVersion
+
+ ^2 "force cleanup of alarms and stepList"!
Item was added:
+ ----- Method: WorldState class>>cleanUp (in category 'class initialization') -----
+ cleanUp
+ "Reset command histories"
+
+ self allInstances do: [ :ea | ea clearCommandHistory ].!
Item was added:
+ ----- Method: WorldState class>>deferredExecutionTimeLimit (in category 'accessing') -----
+ deferredExecutionTimeLimit
+ "Answer the maximum time in milliseconds that should be spent dispatching deferred UI messages in WorldState>>runStepMethodsIn:."
+
+ ^ 200!
Item was added:
+ ----- Method: WorldState class>>deferredUIMessages (in category 'class initialization') -----
+ deferredUIMessages
+
+ ^DeferredUIMessages ifNil: [DeferredUIMessages := SharedQueue new].
+ !
Item was added:
+ ----- Method: WorldState class>>initialize (in category 'class initialization') -----
+ initialize
+ "WorldState initialize"
+
+ MinCycleLapse := 20. "allows 50 frames per second..."
+ DisableDeferredUpdates := false.
+ DeferredUIMessages := SharedQueue new.!
Item was added:
+ ----- Method: WorldState class>>lastCycleTime (in category 'as yet unclassified') -----
+ lastCycleTime
+
+ ^LastCycleTime!
Item was added:
+ ----- Method: WorldState class>>withClassVersion: (in category 'objects from disk') -----
+ withClassVersion: aVersion
+ aVersion <= self classVersion ifTrue: [^self].
+ ^super withClassVersion: aVersion!
Item was added:
+ ----- Method: WorldState>>activeHand (in category 'hands') -----
+ activeHand
+
+ ^ ActiveHand!
Item was added:
+ ----- Method: WorldState>>addAlarm:withArguments:for:at: (in category 'alarms') -----
+ addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime
+ "Add a new alarm with the given set of parameters"
+ self lockAlarmsDuring: [:locked |
+ locked add: (MorphicAlarm
+ scheduledAt: scheduledTime
+ receiver: aTarget
+ selector: aSelector
+ arguments: argArray).
+ ]!
Item was added:
+ ----- Method: WorldState>>addHand: (in category 'hands') -----
+ addHand: aHandMorph
+ "Add the given hand to the list of hands for this world."
+
+ hands := (hands copyWithout: aHandMorph) copyWith: aHandMorph.
+ !
Item was added:
+ ----- Method: WorldState>>addRemoteCanvas: (in category 'Nebraska support') -----
+ addRemoteCanvas: c
+ self canvas: nil. "force recomputation"!
Item was added:
+ ----- Method: WorldState>>adjustAlarmTimes: (in category 'alarms') -----
+ adjustAlarmTimes: nowTime
+ "Adjust the alarm times after some clock weirdness (such as roll-over, image-startup etc)"
+ | deltaTime |
+ deltaTime := nowTime - lastAlarmTime.
+ self lockAlarmsDuring: [:locked |
+ locked do:[:alarm| alarm scheduledTime: alarm scheduledTime + deltaTime].
+ ]!
Item was added:
+ ----- Method: WorldState>>adjustWakeupTimes: (in category 'stepping') -----
+ adjustWakeupTimes: now
+ "Fix the wakeup times in my step list. This is necessary when this world has been restarted after a pause, say because some other view had control, after a snapshot, or because the millisecond clock has wrapped around. (The latter is a rare occurence with a 32-bit clock!!)"
+ | deltaTime |
+ deltaTime := now - lastStepTime.
+ stepList do:[:entry| entry scheduledTime: entry scheduledTime + deltaTime].
+ lastStepTime := now.
+ !
Item was added:
+ ----- Method: WorldState>>adjustWakeupTimesIfNecessary (in category 'stepping') -----
+ adjustWakeupTimesIfNecessary
+ "Fix the wakeup times in my step list if necessary. This is needed after a snapshot, after a long pause (say because some other view had control or because the user was selecting from an MVC-style menu) or when the millisecond clock wraps around (a very rare occurence with a 32-bit clock!!)."
+
+ | now |
+ now := Time millisecondClockValue.
+ ((now < lastStepTime) or: [(now - lastStepTime) > 5000])
+ ifTrue: [self adjustWakeupTimes: now]. "clock slipped"
+ !
Item was added:
+ ----- Method: WorldState>>alarms (in category 'alarms') -----
+ alarms
+
+ ^alarms ifNil: [alarms := MorphicAlarmQueue new]!
Item was added:
+ ----- Method: WorldState>>assuredCanvas (in category 'canvas') -----
+ assuredCanvas
+ remoteServer ifNotNil:[^self assuredRemoteCanvas].
+ (canvas isNil or: [(canvas extent ~= viewBox extent) or: [canvas form depth ~= Display depth]])
+ ifTrue:
+ ["allocate a new offscreen canvas the size of the window"
+ self canvas: (Display defaultCanvasClass extent: viewBox extent)].
+ ^ self canvas!
Item was added:
+ ----- Method: WorldState>>assuredRemoteCanvas (in category 'Nebraska support') -----
+ assuredRemoteCanvas
+ | newCanvas |
+ (self canvas notNil) ifTrue: [ ^self canvas ].
+ newCanvas := MultiCanvas new.
+ newCanvas depth: 32.
+ newCanvas extent: viewBox extent.
+ self remoteCanvasesDo: [ :c | newCanvas addCanvas: c ].
+ newCanvas addCanvas: Display getCanvas.
+
+ "newCanvas := CachingCanvas on: newCanvas."
+ self canvas: newCanvas.
+ ^newCanvas!
Item was added:
+ ----- Method: WorldState>>canvas (in category 'canvas') -----
+ canvas
+
+ ^ canvas!
Item was added:
+ ----- Method: WorldState>>canvas: (in category 'canvas') -----
+ canvas: x
+ canvas := x.
+ damageRecorder isNil
+ ifTrue: [damageRecorder := DamageRecorder new]
+ ifFalse: [damageRecorder doFullRepaint]!
Item was added:
+ ----- Method: WorldState>>checkIfUpdateNeeded (in category 'update cycle') -----
+ checkIfUpdateNeeded
+
+ damageRecorder updateIsNeeded ifTrue: [^true].
+ hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]].
+ ^false "display is already up-to-date"
+ !
Item was added:
+ ----- Method: WorldState>>cleanseStepListForWorld: (in category 'stepping') -----
+ cleanseStepListForWorld: aWorld
+ "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world."
+
+ | deletions morphToStep |
+ deletions := nil.
+ stepList do: [:entry |
+ morphToStep := entry receiver.
+ morphToStep world == aWorld ifFalse:[
+ deletions ifNil: [deletions := OrderedCollection new].
+ deletions addLast: entry]].
+
+ deletions ifNotNil:[
+ deletions do: [:entry|
+ self stopStepping: entry receiver]].
+
+ self lockAlarmsDuring: [:locked |
+ locked copy do: [:entry |
+ morphToStep := entry receiver.
+ (morphToStep isMorph and:[morphToStep world == aWorld])
+ ifFalse:[self removeAlarm: entry selector for: entry receiver]]
+ ].!
Item was added:
+ ----- Method: WorldState>>clearCommandHistory (in category 'undo support') -----
+ clearCommandHistory
+
+ "useful prior to project saves"
+ commandHistory := nil!
Item was added:
+ ----- Method: WorldState>>commandHistory (in category 'undo') -----
+ commandHistory
+ ^commandHistory ifNil:[commandHistory := CommandHistory new]!
Item was added:
+ ----- Method: WorldState>>convertAlarms (in category 'object fileIn') -----
+ convertAlarms
+ "We now store the alarms in a MorphicAlarmQueue, rather than a Heap."
+ alarms ifNotNil: [
+ alarms class == MorphicAlarmQueue ifFalse: [
+ | oldAlarms |
+ oldAlarms := alarms.
+ alarms := MorphicAlarmQueue new.
+ oldAlarms do: [:alarm | alarms add: alarm]
+ ]
+ ].!
Item was added:
+ ----- Method: WorldState>>convertStepList (in category 'object fileIn') -----
+ convertStepList
+ "Convert the old-style step list (an Array of Arrays) into the new-style StepMessage heap"
+
+ | newList |
+ (stepList isKindOf: Heap)
+ ifTrue:
+ [^stepList sortBlock: self stepListSortBlock "ensure that we have a cleaner block"].
+ newList := Heap sortBlock: self stepListSortBlock.
+ stepList do:
+ [:entry | | wakeupTime morphToStep |
+ wakeupTime := entry second.
+ morphToStep := entry first.
+ newList add: (StepMessage
+ scheduledAt: wakeupTime
+ stepTime: nil
+ receiver: morphToStep
+ selector: #stepAt:
+ arguments: nil)].
+ stepList := newList!
Item was added:
+ ----- Method: WorldState>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
+ convertToCurrentVersion: varDict refStream: smartRefStrm
+
+ "Convert the old to new step lists"
+ self convertStepList.
+ self convertAlarms.
+ ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
+
+ !
Item was added:
+ ----- Method: WorldState>>displayWorld:submorphs: (in category 'update cycle') -----
+ displayWorld: aWorld submorphs: submorphs
+ "Update this world's display."
+
+ | deferredUpdateMode handsToDraw allDamage handDamageRects worldDamageRects |
+
+ submorphs do: [:m | m fullBounds]. "force re-layout if needed"
+ self checkIfUpdateNeeded ifFalse: [^ self]. "display is already up-to-date"
+
+ deferredUpdateMode := self doDeferredUpdatingFor: aWorld.
+ deferredUpdateMode ifFalse: [self assuredCanvas].
+
+ worldDamageRects := self drawWorld: aWorld submorphs: submorphs invalidAreasOn: canvas. "repair world's damage on canvas"
+ "self handsDo:[:h| h noticeDamageRects: worldDamageRects]."
+ handsToDraw := self selectHandsToDrawForDamage: worldDamageRects.
+ handDamageRects := handsToDraw collect: [:h | h savePatchFrom: canvas].
+ allDamage := worldDamageRects, handDamageRects.
+
+ handsToDraw reverseDo: [:h | canvas fullDrawMorph: h]. "draw hands onto world canvas"
+
+ "*make this true to flash damaged areas for testing*"
+ Preferences debugShowDamage ifTrue: [aWorld flashRects: allDamage color: Color black].
+
+ canvas finish: allDamage.
+
+ "quickly copy altered rects of canvas to Display:"
+ deferredUpdateMode
+ ifTrue: [self forceDamageToScreen: allDamage]
+ ifFalse: [canvas showAt: aWorld viewBox origin invalidRects: allDamage].
+ handsToDraw do: [:h | h restoreSavedPatchOn: canvas]. "restore world canvas under hands"
+ Display deferUpdates: false; forceDisplayUpdate.
+ !
Item was added:
+ ----- Method: WorldState>>displayWorldSafely: (in category 'update cycle') -----
+ displayWorldSafely: aWorld
+ "Update this world's display and keep track of errors during draw methods."
+
+ [aWorld displayWorld] ifError: [:err :rcvr |
+ "Handle a drawing error"
+ | errCtx errMorph |
+ errCtx := thisContext.
+ [
+ errCtx := errCtx sender.
+ "Search the sender chain to find the morph causing the problem"
+ [errCtx notNil and:[(errCtx receiver isMorph) not]]
+ whileTrue:[errCtx := errCtx sender].
+ "If we're at the root of the context chain then we have a fatal drawing problem"
+ errCtx ifNil:[^Project current handleFatalDrawingError: err].
+ errMorph := errCtx receiver.
+ "If the morph causing the problem has already the #drawError flag set,
+ then search for the next morph above in the caller chain."
+ errMorph hasProperty: #errorOnDraw
+ ] whileTrue.
+ errMorph setProperty: #errorOnDraw toValue: true.
+ "Install the old error handler, so we can re-raise the error"
+ rcvr error: err.
+ ].!
Item was added:
+ ----- Method: WorldState>>doDeferredUpdatingFor: (in category 'update cycle') -----
+ doDeferredUpdatingFor: aWorld
+ "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature."
+ | properDisplay |
+ PasteUpMorph disableDeferredUpdates ifTrue: [^ false].
+ (Display deferUpdates: true) ifNil: [^ false]. "deferred updates not supported"
+ remoteServer ifNotNil:[
+ self assuredCanvas.
+ ^true].
+ properDisplay := canvas notNil and: [canvas form == Display].
+ aWorld == World ifTrue: [ "this world fills the entire Display"
+ properDisplay ifFalse: [
+ aWorld viewBox: Display boundingBox. "do first since it may clear canvas"
+ self canvas: (Display getCanvas copyClipRect: Display boundingBox).
+ ]
+ ].
+ ^ true
+ !
Item was added:
+ ----- Method: WorldState>>doFullRepaint (in category 'canvas') -----
+ doFullRepaint
+
+ damageRecorder doFullRepaint
+ !
Item was added:
+ ----- Method: WorldState>>doOneCycleFor: (in category 'update cycle') -----
+ doOneCycleFor: aWorld
+ "Do one cycle of the interaction loop. This method is called repeatedly when the world is running.
+
+ This is a moderately private method; a better alternative is usually either to wait for events or to check the state of things from #step methods."
+
+ self interCyclePause: (Preferences higherPerformance ifTrue: [1] ifFalse: [MinCycleLapse]).
+ self doOneCycleNowFor: aWorld.!
Item was added:
+ ----- Method: WorldState>>doOneCycleNowFor: (in category 'update cycle') -----
+ doOneCycleNowFor: aWorld
+ "Immediately do one cycle of the interaction loop.
+ This should not be called directly, but only via doOneCycleFor:"
+
+ | capturingGesture |
+ DisplayScreen checkForNewScreenSize.
+ capturingGesture := false.
+ "self flag: #bob. " "need to consider remote hands in lower worlds"
+
+ "process user input events"
+ LastCycleTime := Time millisecondClockValue.
+ self handsDo: [:h |
+ ActiveHand := h.
+ h processEvents.
+ capturingGesture := capturingGesture or: [ h isCapturingGesturePoints ].
+ ActiveHand := nil
+ ].
+
+ "the default is the primary hand"
+ ActiveHand := self hands first.
+
+ "The gesture recognizer needs enough points to be accurate.
+ Therefore morph stepping is disabled while capturing points for the recognizer"
+ capturingGesture ifFalse:
+ [aWorld runStepMethods. "there are currently some variations here"
+ self displayWorldSafely: aWorld].
+ !
Item was added:
+ ----- Method: WorldState>>doOneSubCycleFor: (in category 'update cycle') -----
+ doOneSubCycleFor: aWorld
+ "Like doOneCycle, but preserves activeHand."
+
+ | currentHand |
+ currentHand := ActiveHand.
+ self doOneCycleFor: aWorld.
+ ActiveHand := currentHand!
Item was added:
+ ----- Method: WorldState>>drawWorld:submorphs:invalidAreasOn: (in category 'update cycle') -----
+ drawWorld: aWorld submorphs: submorphs invalidAreasOn: aCanvas
+ "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that
+ were redrawn."
+
+ | rectList n morphs rects validList |
+ rectList := damageRecorder invalidRectsFullBounds: aWorld viewBox.
+ "sort by areas to draw largest portions first"
+ rectList := rectList asArray sort: [:r1 :r2 | r1 area > r2 area].
+ damageRecorder reset.
+ n := submorphs size.
+ morphs := OrderedCollection new: n * 2.
+ rects := OrderedCollection new: n * 2.
+ validList := OrderedCollection new: n * 2.
+
+ "This is added in case we are drawing to a form that is to be used as a texture, and we want the background to be translucent."
+ aWorld color isTranslucent ifTrue:
+ [rectList do: [:r | aCanvas form fill: r fillColor: aWorld color]].
+
+ rectList do:
+ [:dirtyRect |
+ dirtyRect allAreasOutsideList: validList
+ do:
+ [:r | | mm rectToFill remnants c rect i |
+ "Experimental top-down drawing --
+ Traverses top to bottom, stopping if the entire area is filled.
+ If only a single rectangle remains, then continue with the reduced rectangle."
+
+ rectToFill := r.
+ i := 1.
+ [rectToFill isNil or: [i > n]] whileFalse:
+ [mm := submorphs at: i.
+ ((mm fullBounds intersects: r) and: [mm visible])
+ ifTrue:
+ [morphs addLast: mm.
+ rects addLast: rectToFill.
+ remnants := mm areasRemainingToFill: rectToFill.
+ remnants size = 1 ifTrue: [rectToFill := remnants first].
+ remnants isEmpty ifTrue: [rectToFill := nil]].
+ i := i + 1].
+
+ "Now paint from bottom to top, but using the reduced rectangles."
+ rectToFill
+ ifNotNil: [aWorld drawOn: (c := aCanvas copyClipRect: rectToFill)].
+ [morphs isEmpty] whileFalse:
+ [(rect := rects removeLast) == rectToFill
+ ifFalse: [c := aCanvas copyClipRect: (rectToFill := rect)].
+ c fullDrawMorph: morphs removeLast].
+ morphs reset.
+ rects reset.
+ validList add: r]].
+ ^validList!
Item was added:
+ ----- Method: WorldState>>forceDamageToScreen: (in category 'update cycle') -----
+ forceDamageToScreen: allDamage
+
+ "here for the convenience of NebraskaWorldState"
+ Display forceDamageToScreen: allDamage.
+ self remoteCanvasesDo: [ :each |
+ allDamage do: [:r | each forceToScreen: r].
+ each displayIsFullyUpdated.
+ ].!
Item was added:
+ ----- Method: WorldState>>handleFatalDrawingError: (in category 'update cycle') -----
+ handleFatalDrawingError: errMsg
+ "Handle a fatal drawing error."
+ self flag: #toRemove. "Implementation moved to Project, but are there external packages with senders?"
+ Project current handleFatalDrawingError: errMsg
+ !
Item was added:
+ ----- Method: WorldState>>hands (in category 'hands') -----
+ hands
+
+ ^ hands!
Item was added:
+ ----- Method: WorldState>>handsDo: (in category 'hands') -----
+ handsDo: aBlock
+
+ ^ hands do: aBlock!
Item was added:
+ ----- Method: WorldState>>handsReverseDo: (in category 'hands') -----
+ handsReverseDo: aBlock
+
+ ^ hands reverseDo: aBlock!
Item was added:
+ ----- Method: WorldState>>initialize (in category 'initialization') -----
+ initialize
+
+ hands := Array new.
+ damageRecorder:= DamageRecorder new.
+ stepList := Heap sortBlock: self stepListSortBlock.
+ lastStepTime := 0.
+ lastAlarmTime := 0.!
Item was added:
+ ----- Method: WorldState>>interCyclePause: (in category 'update cycle') -----
+ interCyclePause: milliSecs
+ "delay enough that the previous cycle plus the amount of delay will equal milliSecs. If the cycle is already expensive, then no delay occurs. However, if the system is idly waiting for interaction from the user, the method will delay for a proportionally long time and cause the overall CPU usage of Squeak to be low.
+ If the preference #serverMode is enabled, always do a complete delay of 50ms, independant of my argument. This prevents the freezing problem described in Mantis #6581"
+
+ | millisecondsToWait |
+ millisecondsToWait := Preferences serverMode
+ ifTrue: [ 50 ]
+ ifFalse: [
+ (lastCycleTime isNil or: [ CanSurrenderToOS == false ])
+ ifTrue: [ 0 ]
+ ifFalse: [ milliSecs - (Time millisecondsSince: lastCycleTime) ] ].
+ millisecondsToWait > 0 ifTrue: [
+ (interCycleDelay isNil or: [ interCycleDelay beingWaitedOn ])
+ ifTrue: [ interCycleDelay := Delay forMilliseconds: millisecondsToWait ]
+ ifFalse: [ interCycleDelay delayDuration: millisecondsToWait ].
+ interCycleDelay wait ].
+ lastCycleTime := Time millisecondClockValue.
+ CanSurrenderToOS := true.!
Item was added:
+ ----- Method: WorldState>>isStepping: (in category 'stepping') -----
+ isStepping: aMorph
+ "Return true if the given morph is in the step list."
+ lastStepMessage ifNotNil:[(lastStepMessage receiver == aMorph) ifTrue:[^true]].
+ stepList do:[:entry| entry receiver == aMorph ifTrue:[^true]].
+ ^ false!
Item was added:
+ ----- Method: WorldState>>isStepping:selector: (in category 'stepping') -----
+ isStepping: aMorph selector: aSelector
+ "Return true if the given morph is in the step list."
+ lastStepMessage ifNotNil:[
+ (lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
+ ifTrue:[^true]].
+ stepList do:[:entry| (entry receiver == aMorph and:[entry selector == aSelector]) ifTrue:[^true]].
+ ^ false!
Item was added:
+ ----- Method: WorldState>>listOfSteppingMorphs (in category 'stepping') -----
+ listOfSteppingMorphs
+ ^stepList collect:[:entry| entry receiver].
+ !
Item was added:
+ ----- Method: WorldState>>lockAlarmsDuring: (in category 'alarms') -----
+ lockAlarmsDuring: actionBlock
+ "All accesses to the alarms queue is synchronized by a mutex. Answer the result of evaluating the 1-argument 'actionBlock'."
+ alarms ifNil: [alarms := MorphicAlarmQueue new].
+ ^alarms mutex critical: [
+ actionBlock value: alarms
+ ]!
Item was added:
+ ----- Method: WorldState>>recordDamagedRect: (in category 'canvas') -----
+ recordDamagedRect: damageRect
+
+ damageRecorder ifNotNil: [damageRecorder recordInvalidRect: damageRect truncated]
+ !
Item was added:
+ ----- Method: WorldState>>releaseRemoteServer (in category 'Nebraska support') -----
+ releaseRemoteServer
+ "My server has been transferred to some other world. Release pending references"
+ remoteServer := nil.
+ self canvas: nil.!
Item was added:
+ ----- Method: WorldState>>remoteCanvasesDo: (in category 'Nebraska support') -----
+ remoteCanvasesDo: aBlock
+ remoteServer ifNil:[^self].
+ ^remoteServer clients do:[:client| aBlock value: client canvas]!
Item was added:
+ ----- Method: WorldState>>remoteServer (in category 'Nebraska support') -----
+ remoteServer
+ ^remoteServer!
Item was added:
+ ----- Method: WorldState>>remoteServer: (in category 'Nebraska support') -----
+ remoteServer: aNebraskaServer
+ remoteServer ifNotNil:[remoteServer destroy].
+ remoteServer := aNebraskaServer.
+ self canvas: nil.!
Item was added:
+ ----- Method: WorldState>>removeAlarm:for: (in category 'alarms') -----
+ removeAlarm: aSelector for: aTarget
+ "Remove the alarm with the given selector"
+ self lockAlarmsDuring: [:locked |
+ | alarm |
+ alarm := locked
+ detect: [:any | any receiver == aTarget and: [any selector == aSelector]]
+ ifNone: [nil].
+ alarm ifNotNil: [locked remove: alarm]
+ ].
+ !
Item was added:
+ ----- Method: WorldState>>removeHand: (in category 'hands') -----
+ removeHand: aHandMorph
+ "Remove the given hand from the list of hands for this world."
+
+ (hands includes: aHandMorph) ifFalse: [^self].
+ hands := hands copyWithout: aHandMorph.
+ ActiveHand == aHandMorph ifTrue: [ActiveHand := nil].
+ !
Item was added:
+ ----- Method: WorldState>>removeRemoteCanvas: (in category 'Nebraska support') -----
+ removeRemoteCanvas: c
+ self canvas: nil. "force withdrawal of remote from MultiCanvas"
+ !
Item was added:
+ ----- Method: WorldState>>resetDamageRecorder (in category 'canvas') -----
+ resetDamageRecorder
+
+ damageRecorder reset
+ !
Item was added:
+ ----- Method: WorldState>>runLocalStepMethodsIn: (in category 'stepping') -----
+ runLocalStepMethodsIn: aWorld
+ "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world.
+ ar 3/13/1999: Remove buggy morphs from the step list so that they don't raise repeated errors."
+
+ | now morphToStep stepTime priorWorld |
+ now := Time millisecondClockValue.
+ priorWorld := ActiveWorld.
+ ActiveWorld := aWorld.
+ self triggerAlarmsBefore: now.
+ stepList isEmpty
+ ifTrue:
+ [ActiveWorld := priorWorld.
+ ^self].
+ (now < lastStepTime or: [now - lastStepTime > 5000])
+ ifTrue: [self adjustWakeupTimes: now]. "clock slipped"
+ [stepList isEmpty not and: [stepList first scheduledTime < now]]
+ whileTrue:
+ [lastStepMessage := stepList removeFirst.
+ morphToStep := lastStepMessage receiver.
+ (morphToStep shouldGetStepsFrom: aWorld)
+ ifTrue:
+ [lastStepMessage value: now.
+ lastStepMessage ifNotNil:
+ [stepTime := lastStepMessage stepTime ifNil: [morphToStep stepTime].
+ lastStepMessage scheduledTime: now + (stepTime max: 1).
+ stepList add: lastStepMessage]].
+ lastStepMessage := nil].
+ lastStepTime := now.
+ ActiveWorld := priorWorld!
Item was added:
+ ----- Method: WorldState>>runStepMethodsIn: (in category 'stepping') -----
+ runStepMethodsIn: aWorld
+ "Perform periodic activity inbetween event cycles"
+ | queue msg limit stamp |
+ "Limit processing of deferredUIMessages to a max. amount of time"
+ limit := self class deferredExecutionTimeLimit.
+ stamp := Time millisecondClockValue.
+ queue := self class deferredUIMessages.
+ [(Time millisecondsSince: stamp) >= limit
+ or:[(msg := queue nextOrNil) == nil]]
+ whileFalse: [msg value].
+ self runLocalStepMethodsIn: aWorld.
+ !
Item was added:
+ ----- Method: WorldState>>selectHandsToDrawForDamage: (in category 'hands') -----
+ selectHandsToDrawForDamage: damageList
+ "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle."
+
+ | result |
+ result := OrderedCollection new.
+ hands do: [:h |
+ h needsToBeDrawn ifTrue: [
+ h hasChanged
+ ifTrue: [result add: h]
+ ifFalse: [
+ | hBnds |
+ hBnds := h fullBounds.
+ (damageList anySatisfy: [:r | r intersects: hBnds])
+ ifTrue: [result add: h]]]].
+ ^ result
+ !
Item was added:
+ ----- Method: WorldState>>startStepping:at:selector:arguments:stepTime: (in category 'stepping') -----
+ startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime
+ "Add the given morph to the step list. Do nothing if it is already being stepped."
+
+ self stopStepping: aMorph selector: aSelector.
+ self adjustWakeupTimesIfNecessary.
+ stepList add:(
+ StepMessage
+ scheduledAt: scheduledTime
+ stepTime: stepTime
+ receiver: aMorph
+ selector: aSelector
+ arguments: args)!
Item was added:
+ ----- Method: WorldState>>stepListSize (in category 'initialization') -----
+ stepListSize
+ ^ stepList size!
Item was added:
+ ----- Method: WorldState>>stepListSortBlock (in category 'initialization') -----
+ stepListSortBlock
+ ^[ :stepMsg1 :stepMsg2 |
+ stepMsg1 scheduledTime <= stepMsg2 scheduledTime.
+ ]!
Item was added:
+ ----- Method: WorldState>>stopStepping: (in category 'stepping') -----
+ stopStepping: aMorph
+ "Remove the given morph from the step list."
+ lastStepMessage ifNotNil:[
+ (lastStepMessage receiver == aMorph) ifTrue:[lastStepMessage := nil]].
+ stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph]).
+ !
Item was added:
+ ----- Method: WorldState>>stopStepping:selector: (in category 'stepping') -----
+ stopStepping: aMorph selector: aSelector
+ "Remove the given morph from the step list."
+ lastStepMessage ifNotNil:[
+ (lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
+ ifTrue:[lastStepMessage := nil]].
+ stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and:[stepMsg selector == aSelector]]).!
Item was added:
+ ----- Method: WorldState>>triggerAlarmsBefore: (in category 'alarms') -----
+ triggerAlarmsBefore: nowTime
+ "Trigger all pending alarms that are to be executed before nowTime."
+ | triggered |
+ lastAlarmTime ifNil:[lastAlarmTime := nowTime].
+ (nowTime < lastAlarmTime or:[nowTime - lastAlarmTime > 10000])
+ ifTrue:[self adjustAlarmTimes: nowTime].
+ triggered := OrderedCollection new.
+ self lockAlarmsDuring: [:pending |
+ [pending isEmpty not and: [pending first scheduledTime < nowTime]]
+ whileTrue: [triggered add: pending removeFirst]].
+ triggered do: [:alarm | alarm value: nowTime].
+ lastAlarmTime := nowTime.!
Item was added:
+ ----- Method: WorldState>>viewBox (in category 'canvas') -----
+ viewBox
+
+ ^ viewBox!
Item was added:
+ ----- Method: WorldState>>viewBox: (in category 'canvas') -----
+ viewBox: x
+
+ viewBox := x!
Item was added:
+ (PackageInfo named: 'Morphic') postscript: '"Update existing scrollbars."
+ ScrollBar allSubInstances do: [:sb |
+ sb removeAllMorphs; initializeSlider].
+ ScrollPane allSubInstances do: [:sc |
+ sc vScrollBar
+ setValueSelector: #vScrollBarValue:;
+ menuSelector: #vScrollBarMenuButtonPressed:.
+ sc hScrollBar
+ setValueSelector: #hScrollBarValue:;
+ menuSelector: #hScrollBarMenuButtonPressed:.
+ sc vSetScrollDelta; hSetScrollDelta].
+
+ (Preferences dictionaryOfPreferences at: #alternativeWindowBoxesLook) defaultValue: false.
+ "Force SystemProgressMorph to be reset"
+ SystemProgressMorph initialize; reset.
+
+ "Initialize the key bindings and menus"
+ Editor initialize.
+
+ "Retain scrollBar look now that the pref actually does something"
+ Preferences enable: #gradientScrollBars.
+
+ "apply the new icons"
+ MenuIcons initializeIcons.
+ TheWorldMainDockingBar updateInstances.
+
+ "Cleanup old-style preferences here. Remove before new release."
+ Preferences removePreference: #gradientMenu. "Now in MenuMorph."
+ Preferences removePreference: #roundedMenuCorners. "Now in MenuMorph."
+
+ "Fix clipping bug of open windows. New ones are not affected."
+ TransformMorph allInstances do: [:ea | ea clipSubmorphs: true].
+
+ "Now in ScrollBar."
+ Preferences removePreference: #scrollBarsWithoutMenuButton.
+
+ "Keyboard focus indication."
+ PluggableTextMorph allSubInstances do: [:m |
+ m textMorph setProperty: #indicateKeyboardFocus toValue: #never].'!
More information about the Packages
mailing list