'From Pharo1.0beta of 16 May 2008 [Latest update: #10451] on 16 September 2009 at 3:00:23 pm'! Object subclass: #MorphExtension instanceVariableNames: 'locked visible sticky balloonText balloonTextSelector externalName isPartsDonor actorState player eventHandler otherProperties fillStyle layoutPolicy layoutFrame layoutProperties borderStyle cornerStyle actionMap clipSubmorphs' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Kernel'! !Morph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:09'! borderStyle extension ifNil: [^BorderStyle default trackColorFrom: self]. ^(extension borderStyle ifNil: [BorderStyle default]) trackColorFrom: self! ! !Morph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:09'! 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 assureExtension. self extension borderStyle: newStyle. self changed].! ! !Morph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:52'! 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 assureExtension. extension fillStyle: nil. color := aColor. self changed]! ! !Morph methodsFor: 'drawing' stamp: 'gvc 9/11/2009 17:59'! clipSubmorphs "Drawing specific. If this property is set, clip the receiver's submorphs to the receiver's clipping bounds." extension ifNil: [^false]. ^extension clipSubmorphs ifNil: [false]! ! !Morph methodsFor: 'drawing' stamp: 'gvc 9/11/2009 17:59'! 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 == self clipSubmorphs ifFalse:[ self assureExtension. extension clipSubmorphs: aBool. self invalidRect: self fullBounds]! ! !Morph methodsFor: 'events-accessing' stamp: 'gvc 9/11/2009 17:43'! actionMap "Answer an action map" ^self updateableActionMap! ! !Morph methodsFor: 'events-accessing' stamp: 'gvc 9/11/2009 17:43'! updateableActionMap "Answer an updateable action map, saving it in my #actionMap property" | actionMap | self assureExtension. actionMap := extension actionMap. actionMap ifNil: [actionMap := self createActionMap. extension actionMap: actionMap]. ^actionMap! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:57'! 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].! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:06'! 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. ! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:02'! 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].! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'! 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. ! ! !Morph methodsFor: 'rounding' stamp: 'gvc 9/11/2009 17:28'! cornerStyle: aSymbol "This method makes it possible to set up desired corner style. aSymbol has to be one of: #square #rounded" aSymbol == self cornerStyle ifFalse:[ self assureExtension. extension cornerStyle: aSymbol. self changed]! ! !Morph methodsFor: 'visual properties' stamp: 'gvc 9/11/2009 17:27'! cornerStyle "Returns one of the following symbols: #square #rounded according to the current corner style." self assureExtension. ^extension cornerStyle ifNil: [#square]! ! !Morph methodsFor: 'visual properties' stamp: 'gvc 9/11/2009 16:35'! fillStyle "Return the current fillStyle of the receiver." ^extension ifNil: [^color] ifNotNil: [extension fillStyle ifNil: [color]]! ! !Morph methodsFor: 'visual properties' stamp: 'gvc 9/11/2009 16:39'! fillStyle: aFillStyle "Set the current fillStyle of the receiver. Optimized for no change." self assureExtension. extension fillStyle = aFillStyle ifTrue: [^self]. "no change optimization" extension fillStyle: aFillStyle. color := aFillStyle asColor. self changed! ! !BorderedMorph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:17'! borderStyle "Work around the borderWidth/borderColor pair" | style | borderColor ifNil: [^BorderStyle default]. borderWidth isZero ifTrue: [^BorderStyle default]. self assureExtension. style := extension borderStyle ifNil: [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."]. extension borderStyle: style]. ^style trackColorFrom: self! ! !BorderedMorph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:16'! borderStyle: aBorderStyle "Work around the borderWidth/borderColor pair" aBorderStyle = self borderStyle ifTrue: [^self]. self assureExtension. "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: [extension borderStyle: nil. borderWidth := 0. ^self changed]. extension borderStyle: aBorderStyle. borderWidth := aBorderStyle width. borderColor := aBorderStyle style == #simple ifTrue: [aBorderStyle color] ifFalse: [aBorderStyle style]. self changed! ! !EllipseMorph methodsFor: 'rounding' stamp: 'gvc 9/16/2009 13:45'! cornerStyle: aSymbol "Set the receiver's corner style. But, in this case, do *not*" (extension isNil or: [self cornerStyle == aSymbol]) ifTrue: [^self]. extension cornerStyle: nil self changed! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:41'! actionMap "Answer the value of actionMap" ^actionMap ifNil: [self valueOfProperty: #actionMap ifAbsent: []]! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:39'! actionMap: anObject "Set the value of actionMap" actionMap := anObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 18:10'! borderStyle "Answer the value of borderStyle" ^borderStyle! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:08'! borderStyle: anObject "Set the value of borderStyle" borderStyle := anObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 18:10'! clipSubmorphs "Answer the value of clipSubmorphs" ^clipSubmorphs! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:58'! clipSubmorphs: anObject "Set the value of clipSubmorphs" clipSubmorphs := anObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 18:10'! cornerStyle "Answer the value of cornerStyle" ^cornerStyle! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:23'! cornerStyle: anObject "Set the value of cornerStyle" cornerStyle := anObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 18:12'! fillStyle "Answer the value of fillStyle" ^ fillStyle! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 16:55'! fillStyle: anObject "Set the value of fillStyle" fillStyle := anObject! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 18:10'! layoutFrame ^layoutFrame! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 16:45'! layoutFrame: aLayoutFrame layoutFrame := aLayoutFrame! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 18:12'! layoutPolicy ^layoutPolicy! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 16:47'! layoutPolicy: aLayoutPolicy layoutPolicy := aLayoutPolicy! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 18:12'! layoutProperties ^layoutProperties! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 16:47'! layoutProperties: newProperties "Return the current layout properties associated with the receiver" layoutProperties := newProperties! ! !MorphExtension methodsFor: 'connectors-copying' stamp: 'gvc 9/16/2009 14:08'! 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" fillStyle := fillStyle veryDeepCopyWith: deepCopier. layoutPolicy := layoutPolicy veryDeepCopyWith: deepCopier. layoutFrame := layoutFrame veryDeepCopyWith: deepCopier. layoutProperties := layoutProperties veryDeepCopyWith: deepCopier. borderStyle := borderStyle veryDeepCopyWith: deepCopier. cornerStyle := cornerStyle veryDeepCopyWith: deepCopier. actionMap := actionMap veryDeepCopyWith: deepCopier. clipSubmorphs := clipSubmorphs veryDeepCopyWith: deepCopier. 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 ]]. ! ! !MultistateButtonMorph methodsFor: 'updating' stamp: 'gvc 9/11/2009 17:05'! changed "Update the fillStyle here." self assureExtension. extension fillStyle: self fillStyleToUse. color := self fillStyle asColor. super changed! ! !PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/11/2009 17:54'! adoptPaneColor: paneColor "Change our color too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self assureExtension. extension fillStyle ifNil: [self color: paneColor]. self borderStyle baseColor: paneColor darker! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/11/2009 17:54'! changed "Update the fillStyle here." |lc pc bs| self assureExtension. self borderWidth > 0 ifTrue: [ extension borderStyle: (bs := self borderStyleToUse). borderColor := bs style. borderWidth := bs width]. extension fillStyle: self fillStyleToUse. self layoutInset: (self theme buttonLabelInsetFor: self). color := self fillStyle asColor. (self labelMorph respondsTo: #enabled:) ifTrue: [self labelMorph enabled: self enabled] ifFalse: [(self labelMorph isNil or: [label isMorph]) ifFalse: [ pc := self normalColor. lc := self enabled ifTrue: [pc contrastingColor] ifFalse: [pc contrastingColor muchDarker]. self labelMorph color: lc]]. super changed! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/11/2009 17:56'! indicateModalChild "Flash the button border." |fs c w d| fs := self fillStyle. c := self color alphaMixed: 0.5 with: Color black. w := self world. d := 0. self assureExtension. 2 timesRepeat: [ (Delay forDuration: d milliSeconds) wait. d := 200. extension fillStyle: c. color := c. self invalidRect: self bounds. w ifNotNil: [w displayWorldSafely]. (Delay forDuration: d milliSeconds) wait. self fillStyle: fs. w ifNotNil: [w displayWorldSafely]. self invalidRect: self bounds] ! ! !PluggableThemedPanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/11/2009 17:03'! color: aColor "Set the pane color." self assureExtension. extension fillStyle ifNil: [ super color: aColor]! ! !PolygonMorph methodsFor: 'rounding' stamp: 'gvc 9/11/2009 17:30'! cornerStyle: aSymbol "Set the receiver's corner style. But, in this case, do *not*" (extension isNil or: [self cornerStyle == aSymbol]) ifTrue: [^self]. extension cornerStyle: nil self changed! ! !TableLayout methodsFor: 'nil' stamp: 'ar 11/14/2000 17:10'! layoutLeftToRight: aMorph in: newBounds "An optimized left-to-right list layout" | inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props | 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| 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 > maxX ifTrue:[sizeX := maxX]]. sizeY < minY ifTrue:[sizeY := minY] ifFalse:[sizeY > maxY ifTrue:[sizeY := 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 < 0 ifTrue:[extra := 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 < 0 ifTrue:[extra := 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 == nil] 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. ]. ! ! !TableLayout methodsFor: 'nil' stamp: 'ar 11/14/2000 17:12'! layoutTopToBottom: aMorph in: newBounds "An optimized top-to-bottom list layout" | inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props | 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| 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 > maxX ifTrue:[sizeX := maxX]]. sizeY < minY ifTrue:[sizeY := minY] ifFalse:[sizeY > maxY ifTrue:[sizeY := 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 < 0 ifTrue:[extra := 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 < 0 ifTrue:[extra := 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 == nil] 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. ].! ! !TextMorph methodsFor: 'visual properties' stamp: 'gvc 9/11/2009 16:36'! fillStyle "Return the current fillStyle of the receiver." self assureExtension. ^extension fillStyle ifNil: [ backgroundColor ifNil: [Color transparent]]! ! !TextMorph methodsFor: 'visual properties' stamp: 'gvc 9/11/2009 16:40'! fillStyle: aFillStyle "Set the current fillStyle of the receiver." backgroundColor := aFillStyle asColor. super fillStyle: aFillStyle! ! !MorphExtension reorganize! ('*etoys-accessing' player) ('accessing' actionMap actionMap: actorState actorState: balloonText balloonTextSelector balloonTextSelector: balloonText: borderStyle borderStyle: clipSubmorphs clipSubmorphs: cornerStyle cornerStyle: eventHandler eventHandler: externalName: fillStyle fillStyle: isPartsDonor isPartsDonor: locked locked: otherProperties: player: sticky sticky: visible visible:) ('accessing - layout properties' layoutFrame layoutFrame: layoutPolicy layoutPolicy: layoutProperties layoutProperties:) ('accessing - other properties' assureOtherProperties hasProperty: initializeOtherProperties otherProperties removeOtherProperties removeProperty: setProperty:toValue: sortedPropertyNames valueOfProperty: valueOfProperty:ifAbsentPut: valueOfProperty:ifAbsent:) ('connectors-copying' copyWeakly propertyNamesNotCopied veryDeepFixupWith: veryDeepInner:) ('initialization' initialize) ('object filein' convertProperty:toValue:) ('objects from disk' comeFullyUpOnReload:) ('other' inspectElement isDefault) ('printing' printOn:) ('viewer' externalName) ! MenuItemMorph removeSelector: #hResizing! MenuItemMorph removeSelector: #vResizing!