Tim Felgentreff uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-tfel.1242.mcz
==================== Summary ====================
Name: Morphic-tfel.1242
Author: tfel
Time: 9 August 2016, 9:16:18.74266 am
UUID: b13711b1-50f4-2f41-bc5b-5bc6b23c2515
Ancestors: Morphic-tfel.1241
fix hotspot for color picker cursor
=============== Diff against Morphic-mt.1240 ===============
Item was changed:
----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
supplementaryPartsDescriptions
"Extra items for parts bins"
^ {DescriptionForPartsBin
+ formalName: 'Circle' translatedNoop
+ categoryList: {'Graphics' translatedNoop}
+ documentation: 'A circular shape' translatedNoop
- formalName: 'Circle1'
- categoryList: #('Graphics')
- documentation: 'A circular shape'
globalReceiverSymbol: #CircleMorph
nativitySelector: #newStandAlone.
+ DescriptionForPartsBin
+ formalName: 'Pin' translatedNoop
+ categoryList: {'Connectors' translatedNoop}
+ documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop
- "DescriptionForPartsBin
- formalName: 'Pin'
- categoryList: #('Connectors')
- documentation: 'An attachment point for Connectors that you can embed in another Morph.'
globalReceiverSymbol: #NCPinMorph
+ nativitySelector: #newPin.
- nativitySelector: #newPin."
}!
Item was changed:
----- 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 @ 31. "<<<< the form was changed a bit??"
- 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 changed:
----- 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 insetBy: 2) fillColor: feedbackColor.
- originalForm fill: FeedbackBox fillColor: feedbackColor.
self form: originalForm.
+ selectedColor _ aColor.
- selectedColor := aColor.
updateContinuously ifTrue: [self updateTargetColor].
self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).!
Item was changed:
----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Ellipse' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'An elliptical or circular shape' translatedNoop!
- ^ self partName: 'Ellipse'
- categories: #('Graphics' 'Basic')
- documentation: 'An elliptical or circular shape'!
Item was changed:
----- Method: HaloMorph>>addDupHandle: (in category 'handles') -----
addDupHandle: haloSpec
"Add the halo that offers duplication, or, when shift is down, make-sibling"
+ | aSelector |
+ aSelector := innerTarget couldMakeSibling
+ ifTrue:
+ [#doDupOrMakeSibling:with:]
+ ifFalse:
+ [#doDup:with:].
- self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self
+ self addHandle: haloSpec on: #mouseDown send: aSelector to: self
+
!
Item was changed:
----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') -----
addHandlesForWorldHalos
"Add handles for world halos, like the man said"
| box w |
+ w _ self world ifNil:[target world].
- w := self world ifNil:[target world].
self removeAllMorphs. "remove old handles, if any"
self bounds: target bounds.
+ box _ w bounds insetBy: self handleSize // 2.
- box := w bounds insetBy: 9.
target addWorldHandlesTo: self box: box.
Preferences uniqueNamesInHalos ifTrue:
[innerTarget assureExternalName].
self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
+ growingOrRotating _ false.
- growingOrRotating := false.
self layoutChanged.
self changed.
!
Item was changed:
----- Method: HaloMorph>>addViewingHandle: (in category 'handles') -----
addViewingHandle: haloSpec
+ "If appropriate, add a special Viewing halo handle to the receiver. On 26 Sept 07, we decided to eliminate this item from the UI, so the code of is method is now commented out...
- "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 changed:
----- Method: HaloMorph>>basicBox (in category 'private') -----
basicBox
| aBox minSide anExtent w |
+ minSide _ 4 * self handleSize.
+ anExtent _ ((self width + self handleSize + 8) max: minSide) @
- 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].
- aBox := Rectangle center: self center extent: anExtent.
- w := self world ifNil:[target outermostWorldMorph].
^ w
ifNil:
[aBox]
ifNotNil:
+ [aBox intersect: (w viewBox insetBy: self handleSize // 2)]
- [aBox intersect: (w viewBox insetBy: 8@8)]
!
Item was changed:
----- Method: HaloMorph>>doDirection:with: (in category 'private') -----
doDirection: anEvent with: directionHandle
+ "The mouse went down on the forward-direction halo handle; respond appropriately."
+
anEvent hand obtainHalo: self.
+ anEvent shiftPressed
+ ifTrue:
+ [directionArrowAnchor _ (target point: target referencePosition in: self world) rounded.
+ self positionDirectionShaft: directionHandle.
+ self removeAllHandlesBut: directionHandle.
+ directionHandle setProperty: #trackDirectionArrow toValue: true]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: directionHandle]!
- self removeAllHandlesBut: directionHandle!
Item was changed:
----- Method: HaloMorph>>handleSize (in category 'private') -----
handleSize
^ Preferences biggerHandles
+ ifTrue: [30]
- ifTrue: [20]
ifFalse: [16]!
Item was changed:
----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') -----
prepareToTrackCenterOfRotation: evt with: rotationHandle
+ "The mouse went down on the center of rotation."
+
evt hand obtainHalo: self.
+ evt shiftPressed
+ ifTrue:
+ [self removeAllHandlesBut: rotationHandle.
+ rotationHandle setProperty: #trackCenterOfRotation toValue: true.
+ evt hand showTemporaryCursor: Cursor blank]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: rotationHandle]!
- evt shiftPressed ifTrue:[
- self removeAllHandlesBut: rotationHandle.
- ] ifFalse:[
- rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
- self startDrag: evt with: rotationHandle
- ].
- evt hand showTemporaryCursor: Cursor blank!
Item was changed:
----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') -----
setCenterOfRotation: evt with: rotationHandle
| localPt |
evt hand obtainHalo: self.
evt hand showTemporaryCursor: nil.
+ (rotationHandle hasProperty: #trackCenterOfRotation) ifTrue:
+ [localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
+ innerTarget setRotationCenterFrom: localPt].
+
+ rotationHandle removeProperty: #trackCenterOfRotation.
+ self endInteraction!
- (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
- localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
- innerTarget setRotationCenterFrom: localPt.
- ].
- rotationHandle removeProperty: #dragByCenterOfRotation.
- self endInteraction
- !
Item was changed:
----- 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"
+ (directionHandle hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ target setDirectionFrom: directionHandle center.
+ directionHandle removeProperty: #trackDirectionArrow.
+ self endInteraction]!
- anEvent hand obtainHalo: self.
- target setDirectionFrom: directionHandle center.
- self endInteraction!
Item was changed:
----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') -----
trackCenterOfRotation: anEvent with: rotationHandle
(rotationHandle hasProperty: #dragByCenterOfRotation)
ifTrue:[^self doDrag: anEvent with: rotationHandle].
+ (rotationHandle hasProperty: #trackCenterOfRotation)
+ ifTrue:
+ [anEvent hand obtainHalo: self.
+ rotationHandle center: anEvent cursorPoint]!
- anEvent hand obtainHalo: self.
- rotationHandle center: anEvent cursorPoint.!
Item was changed:
----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') -----
trackDirectionArrow: anEvent with: shaft
+ (shaft hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
+ self layoutChanged]!
- anEvent hand obtainHalo: self.
- shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
- self layoutChanged!
Item was changed:
----- Method: HandleMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self extent: 16 @ 16.
- self extent: 8 @ 8.
!
Item was changed:
----- Method: IconicButton>>stationarySetup (in category 'initialization') -----
stationarySetup
+ "Set up event handlers for mouse actions. Should be spelled stationery..."
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.
+
+ self on: #click send: #launchPartFromClick to: self!
- self on: #mouseUp send: #borderThick to: self.!
Item was changed:
----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Image' translatedNoop
+ categories: #()
+ documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.' translatedNoop!
- ^ 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 changed:
----- 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' translatedNoop. 'A non-editable picture of something' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Joystick' translatedNoop
+ categories: {'Basic' translatedNoop}
+ documentation: 'A joystick-like control' translatedNoop!
- ^ self partName: 'Joystick'
- categories: #('Useful')
- documentation: 'A joystick-like control'!
Item was changed:
----- 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' translatedNoop. 'A joystick-like control' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Scripting'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ "Answer a description for the parts bin."
+
+ ^ self partName: 'Line' translatedNoop
+ categories: {'Graphics' translatedNoop}
+ documentation: 'A straight line. Shift-click to get handles and move the ends.' translatedNoop!
- ^ self partName: 'Line'
- categories: #('Graphics' 'Basic')
- documentation: 'A straight line. Shift-click to get handles and move the ends.'!
Item was changed:
----- 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.
- ActiveWorld addMorph: self centeredNear: aPoint.
self world displayWorld. "show myself"
+ aBlock value]
+ ensure: [self delete]!
- aBlock value.
- self delete!
Item was changed:
----- Method: MenuIcons class>>iconForMenuItem: (in category 'menu decoration') -----
iconForMenuItem: anItem
+ "Answer the icon (or nil) corresponding to a given menu item."
- "Answer the icon (or nil) corresponding to the (translated) string."
+ | aKey |
+ aKey _ (anItem selector == #undoOrRedoCommand)
+ ifTrue:
+ ['undo (z)' translated] "Actual wording changes dynamically"
+ ifFalse:
+ [anItem contents asString].
+ ^ TranslatedIcons at: aKey asLowercase ifAbsent: [nil]!
- ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]!
Item was changed:
----- Method: MenuMorph>>delete (in category 'initialization') -----
delete
+ "Delete the receiver."
+
+ activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]].
+ self isFlexed ifTrue: [^ owner delete].
+ ^ super delete!
- activeSubMenu ifNotNil:[activeSubMenu delete].
- ^super delete!
Item was changed:
----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') -----
serviceLoadMorphFromFile
"Answer a service for loading a .morph file"
^ SimpleServiceEntry
provider: self
+ label: 'load as morph' translatedNoop
- label: 'load as morph'
selector: #fromFileName:
+ description: 'load as morph' translatedNoop
+ buttonLabel: 'load' translatedNoop!
- description: 'load as morph'
- buttonLabel: 'load'!
Item was changed:
----- 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 w |
+ menu _ MenuMorph new defaultTarget: self.
+ w _ self world.
+ self potentialEmbeddingTargets reverseDo: [:m |
+ menu add: (m == w ifTrue: ['desktop' translated] ifFalse: [m knownName ifNil:[m class name asString]]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}.
+ m == self topRendererOrSelf owner ifTrue:
+ [menu lastItem color: Color red]].
+ aMenu ifNotNil:
+ [menu submorphCount > 0
+ ifTrue:[aMenu add:'embed into' translated subMenu: 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 changed:
----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') -----
addFlexShell
"Wrap a rotating and scaling shell around this morph."
+ | oldHalo flexMorph myWorld anIndex morphOwner |
- | oldHalo flexMorph myWorld anIndex |
myWorld := self world.
+ oldHalo:= self halo.
+ self owner ifNotNil:[ morphOwner := self owner]
+ ifNil:[morphOwner := self currentWorld].
+
+ anIndex := morphOwner submorphIndexOf: self.
+ morphOwner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self)
- 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 changed:
----- Method: Morph>>addHaloActionsTo: (in category 'menus') -----
addHaloActionsTo: aMenu
"Add items to aMenu representing actions requestable via halo"
| subMenu |
+ subMenu _ MenuMorph new defaultTarget: self.
- 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 add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles.
subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.
+ subMenu add: 'tile representing this object' translated target: self action: #tearOffTile.
- 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 changed:
----- 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 notNil and: [aNumber <= submorphs size])
- (aNumber <= submorphs size)
ifTrue:
[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
ifFalse:
+ [self addMorphBack: aMorph]!
- [self addMorphBack: aMorph]
- !
Item was changed:
----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') -----
chooseNewGraphicCoexisting: aBoolean
"Allow the user to choose a different form for her form-based morph"
+
| replacee aGraphicalMenu |
+ self isInWorld ifFalse: "menu must have persisted for a not-in-world object."
+ [aGraphicalMenu := ActiveWorld submorphThat:
+ [:m | (m isKindOf: GraphicalMenu) and: [m target == self]]
+ ifNone:
+ [^ self].
+ ^ aGraphicalMenu show; flashBounds].
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 changed:
----- Method: Morph>>couldMakeSibling (in category 'testing') -----
couldMakeSibling
"Answer whether it is appropriate to ask the receiver to make a sibling"
+ ^ self isWorldMorph not!
- ^ true!
Item was changed:
----- Method: Morph>>goBehind (in category 'submorphs-add/remove') -----
goBehind
+ "Move the receiver to bottom z-order."
+ | topRend |
+ topRend := self topRendererOrSelf.
+ topRend owner ifNotNilDo:
+ [:own | own addMorphNearBack: topRend]
- owner addMorphNearBack: self.
!
Item was changed:
----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') -----
invokeMetaMenu: evt
+ "Put up the 'meta' menu, invoked via control-click, unless eToyFriendly is true."
+
| menu |
+ Preferences eToyFriendly ifTrue: [^ self].
+
+ menu _ self buildMetaMenu: evt.
- menu := self buildMetaMenu: evt.
menu addTitle: self externalName.
+ menu popUpEvent: evt in: self world!
- self world ifNotNil: [
- menu popUpEvent: evt in: self world
- ]!
Item was changed:
----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') -----
obtrudesBeyondContainer
"Answer whether the receiver obtrudes beyond the bounds of its container"
+ | top formerOwner |
- | top |
top := self topRendererOrSelf.
+ top owner ifNil: [^ false].
+ ^ top owner isHandMorph
+ ifTrue:
+ [((formerOwner := top formerOwner) notNil and: [formerOwner isInWorld])
+ ifFalse:
+ [false]
+ ifTrue:
+ [(formerOwner boundsInWorld containsRect: top boundsInWorld) not]]
+ ifFalse:
+ [(top owner bounds containsRect: top bounds) not]!
- (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
- ^(top owner bounds containsRect: top bounds) not!
Item was changed:
----- Method: Morph>>on:send:to: (in category 'event handling') -----
on: eventName send: selector to: recipient
+ "When the given event occurs, send the given selector to the given recipient. If the given selector is nil, rescind any earlier handling for the given event type,"
+
+ self eventHandler ifNil:
+ [selector ifNil: [^ self]. "Don't pointlessly create an event handler!!"
+ self eventHandler: EventHandler new].
- self eventHandler ifNil: [self eventHandler: EventHandler new].
self eventHandler on: eventName send: selector to: recipient!
Item was changed:
----- Method: Morph>>openViewerForArgument (in category 'player viewer') -----
openViewerForArgument
+ Cursor wait
+ showWhile: [self presenter viewMorph: self]!
- "Open up a viewer for a player associated with the morph in question. "
- self presenter viewMorph: self!
Item was changed:
----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') -----
overlapsShadowForm: itsShadow bounds: itsBounds
"Answer true if itsShadow and my shadow overlap at all"
+ | overlapExtent overlap myRect myShadow goalRect goalShadow bb |
+ overlap _ self fullBounds intersect: itsBounds.
+ overlapExtent _ overlap extent.
- | andForm overlapExtent |
- overlapExtent := (itsBounds intersect: self fullBounds) extent.
overlapExtent > (0 @ 0)
ifFalse: [^ false].
+ myRect := overlap translateBy: 0 @ 0 - self topLeft.
+ myShadow := (self imageForm contentsOfArea: myRect) stencil.
+ goalRect := overlap translateBy: 0 @ 0 - itsBounds topLeft.
+ goalShadow := (itsShadow contentsOfArea: goalRect) stencil.
+
+ "compute a pixel-by-pixel AND of the two stencils. Result will be black
+ (pixel value = 1) where black parts of the stencils overlap"
+ bb := BitBlt toForm: myShadow.
+ bb
+ copyForm: goalShadow
+ to: 0 @ 0
+ rule: Form and.
+
+ ^(bb destForm tallyPixelValues second) > 0 !
- 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 changed:
----- Method: Morph>>roundUpStrays (in category 'miscellaneous') -----
roundUpStrays
+ "Bring submorphs of playfieldlike structures in the receiver's interior back within view."
+
+ self submorphsDo:
+ [:m | m isPlayfieldLike ifTrue: [m roundUpStrays]]!
- self submorphs
- do: [:each | each roundUpStrays]!
Item was changed:
----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
slideBackToFormerSituation: evt
+ "A drop of the receiver having been rejected, slide it back to where it came from, if possible."
+
| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
formerOwner := self formerOwner.
formerPosition := self formerPosition.
+ (aWorld := evt hand world) ifNil: [^ self delete]. "Likely a moribund hand from an EventRecorder playback."
+
- 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.
+ "The OLPC Virtual Screen wouldn't notice the last update here."
+ Display forceToScreen: (endPoint extent: slideForm extent).
formerOwner addMorph: self.
self position: formerPosition.
self justDroppedInto: formerOwner event: evt!
Item was changed:
----- Method: Morph>>useGradientFill (in category 'visual properties') -----
useGradientFill
"Make receiver use a solid fill style (e.g., a simple color)"
+
+ | fill color1 color2 fil |
+ ((fil := self fillStyle) notNil and: [fil isSymbol not] and: [fil isGradientFill]) ifTrue:[^self]. "Already done"
+ color1 _ self color asColor.
+ color2 _ color1 negated.
+ fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
- | 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 changed:
----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') -----
wantsHaloFromClick
+
+ ^ self valueOfProperty: #wantsHaloFromClick ifAbsent: [^true].!
- ^ true!
Item was changed:
----- Method: MorphicProject>>updateLocaleDependents (in category 'language') -----
updateLocaleDependents
"Set the project's natural language as indicated"
ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
viewerOrScriptor localeChanged].
Flaps disableGlobalFlaps: false.
+ (Preferences eToyFriendly or: [Smalltalk globals at: #SugarNavigatorBar ifPresent: [:c | c showSugarNavigator] ifAbsent: [false]])
- Preferences eToyFriendly
ifTrue: [
Flaps addAndEnableEToyFlaps.
ActiveWorld addGlobalFlaps]
ifFalse: [Flaps enableGlobalFlaps].
(Project current isFlapIDEnabled: 'Navigator' translated)
ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].
ScrapBook default emptyScrapBook.
MenuIcons initializeTranslations.
super updateLocaleDependents.
"self setFlaps.
self setPaletteFor: aLanguageSymbol."
!
Item was changed:
----- 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 := 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 wantsMouseOverHalos: false.
proto beSticky.
^ proto!
Item was changed:
----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
"Answer a basis for names of default instances of the receiver"
+ ^ 'playfield' translatedNoop!
- ^ 'playfield'!
Item was changed:
----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') -----
addPenMenuItems: menu hand: aHandMorph
"Add a pen-trails-within submenu to the given menu"
+ menu add: 'pen trails...' translated target: self selector: #putUpPenTrailsSubmenu.
+ menu balloonTextForLastItem: 'its governing pen trails drawn within' translated!
- menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu!
Item was changed:
----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') -----
addPenTrailsMenuItemsTo: aMenu
"Add items relating to pen trails to aMenu"
| oldTarget |
+ oldTarget _ aMenu defaultTarget.
- 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 addLine.
+ aMenu addUpdating: #batchPenTrailsString action: #toggleBatchPenTrails.
+ aMenu balloonTextForLastItem: 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.' translated.
+
aMenu defaultTarget: oldTarget!
Item was changed:
----- Method: PasteUpMorph>>addWorldToggleItemsToHaloMenu: (in category 'menu & halo') -----
addWorldToggleItemsToHaloMenu: aMenu
+ "Add toggle items for the world to the halo menu .... July 2009: no longer in world halo menu"
- "Add toggle items for the world to the halo menu"
+ "aMenu addUpdating: #showTabsString
+ target: CurrentProjectRefactoring
+ action: #currentToggleFlapsSuppressed "!
- #(
- (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 changed:
----- 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.
+ self changed "redraw"
- self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
!
Item was changed:
----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') -----
chooseClickTarget
Cursor crossHair showWhile:
[Sensor waitButton].
Cursor down showWhile:
[Sensor anyButtonPressed].
+ ^ (self morphsAt: Sensor cursorPoint) first topRendererOrSelf!
- ^ (self morphsAt: Sensor cursorPoint) first!
Item was changed:
----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') -----
correspondingFlapTab
+ "If there is a flap tab whose referent is me, return it, else return nil. Will also work for flaps on the edge of embedded subareas such as within scripting-areas, but more slowly."
+
- "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]].
+
+ "Catch guys in embedded worldlets"
+ ActiveWorld allMorphs do:
+ [:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]].
+
^ nil!
Item was changed:
----- 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' translatedNoop]!
- ['world']!
Item was changed:
----- 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@0) anyShapeFill reverse.
+ screenForm _ Form fromDisplay: (topLeft extent: outline extent).
- outline := poly shadowForm.
- topLeft := outline offset.
- exterior := (outline offset: 0@0) anyShapeFill reverse.
- screenForm := Form fromDisplay: (topLeft extent: outline extent).
screenForm eraseShape: exterior.
+ innerForm _ screenForm trimBordersOfColor: Color transparent.
+ ActiveHand showTemporaryCursor: nil.
- innerForm := screenForm trimBordersOfColor: Color transparent.
innerForm isAllWhite ifFalse:
[hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was changed:
----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
flapTab
+ "Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'"
+
| ww |
self isFlap ifFalse:[^nil].
+ ww _ self presenter associatedMorph ifNil: [ActiveWorld].
+ ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]!
- ww := self world ifNil: [World].
- ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]!
Item was changed:
----- 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>'])
+ , 'grid visible when gridding' translated!
- , 'show grid when gridding' translated!
Item was changed:
----- Method: PasteUpMorph>>installFlaps (in category 'world state') -----
installFlaps
"Get flaps installed within the bounds of the receiver"
+ | localFlapTabs |
Project current assureFlapIntegrity.
self addGlobalFlaps.
+ localFlapTabs := self localFlapTabs.
+ localFlapTabs do: [:each | each visible: false].
+
+ Preferences eToyFriendly ifTrue: [
+ ProgressInitiationException display: 'Building Viewers...' translated
+ during: [:bar |
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld.
+ bar value: i / self localFlapTabs size]].
+ ] ifFalse: [
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld]].
+
- self localFlapTabs do:
- [:aFlapTab | aFlapTab adaptToWorld].
self assureFlapTabsFitOnScreen.
self bringTopmostsToFront!
Item was changed:
----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') -----
presentCardAndStackMenu
"Put up a menu holding card/stack-related options."
| aMenu |
+ aMenu _ MenuMorph new defaultTarget: self.
- aMenu := MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
+ aMenu addTitle: 'card and stack' translated.
+ aMenu add: 'add new card' translated action: #insertCard.
+ aMenu add: 'delete this card' translated action: #deleteCard.
+ aMenu add: 'go to next card' translated action: #goToNextCardInStack.
+ aMenu add: 'go to previous card' translated action: #goToPreviousCardInStack.
- 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' translated action: #showForegroundObjects.
+ aMenu add: 'show background objects' translated action: #showBackgroundObjects.
+ aMenu add: 'show designations' translated action: #showDesignationsOfObjects.
+ aMenu add: 'explain designations' translated action: #explainDesignations.
- 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 changed:
----- Method: PasteUpMorph>>referencePool (in category 'objects from disk') -----
referencePool
^ self
valueOfProperty: #References
+ ifAbsentPut: [WeakValueDictionary new]
+ !
- ifAbsentPut: [OrderedCollection new]
-
- !
Item was changed:
----- 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 changed:
----- 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]!
- aPlayer startRunning; step; stopRunning].
-
- self allScriptors do:
- [:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
- !
Item was changed:
----- 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 stopSound.
+ aPlayer stopRunning].
- aPlayer stopRunning].
- self allScriptors do:
- [:aScript | aScript pauseIfTicking].
self world updateStatusForAllScriptEditors!
Item was changed:
----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') -----
triggerClosingScripts
"If the receiver has any scripts set to run on closing, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllClosingScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllClosingScripts]!
Item was changed:
----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') -----
triggerOpeningScripts
"If the receiver has any scripts set to run on opening, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllOpeningScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllOpeningScripts]!
Item was changed:
----- 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:
+ [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]!
- [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 changed:
----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
setTextColor: aColor
"Set the color of my text to the given color"
+ textMorph textColor: aColor!
- textMorph color: aColor!
Item was changed:
----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Polygon' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ 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.' translatedNoop!
- ^ 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 changed:
----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu 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."
+
- addCustomMenuItems: aMenu hand: aHandMorph
- | |
super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles.
+ vertices size > 2 ifTrue:
+ [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed].
+
+ aMenu addUpdating: #smoothPhrase target: self action: #toggleSmoothing.
+ aMenu addLine.
+ aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
+
+ self isOpen ifTrue:
+ [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]].!
- 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 changed:
----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
+
+ ^ Color black
+
+ "Until September 2007, this had long been...
^ Color
r: 0.0
g: 0.419
+ b: 0.935"!
- b: 0.935!
Item was changed:
----- Method: PolygonMorph>>fillStyle (in category 'visual properties') -----
fillStyle
+ "Answer the receiver's fillStyle. For an *open* polygon, we return the borderColor, provided it's a true color rather than something strange like the symbol #raised."
+ | aColor |
self isOpen
+ ifTrue:
+ [(aColor := self borderColor) isColor ifTrue: [^ aColor]]. "easy access to line color from halo -- di's old note"
+
+ ^ super fillStyle!
- ifTrue: [^ self borderColor "easy access to line color from halo"]
- ifFalse: [^ super fillStyle]!
Item was changed:
----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') -----
handlesShowingPhrase
+ "Answer a phrase characterizing whether handles are showing or not."
+
+ ^ (self showingHandles ifTrue: ['<yes>'] ifFalse: ['<no>']), ('show handles' translated)!
- ^ (self showingHandles
- ifTrue: ['hide handles']
- ifFalse: ['show handles']) translated!
Item was changed:
----- Method: PolygonMorph>>initialize (in category 'initialization') -----
initialize
+ "initialize the state of the receiver. This sets up a 4-sided polygon as the default."
+
- "initialize the state of the receiver"
super initialize.
+
+ vertices _ Array
+ with: 15 @ 0
+ with: 45 @ 20
+ with: 60@60
+ with: 0 @ 60.
+ vertexCursor _ 1.
+ closed _ true.
+ smoothCurve _ false.
+ arrows _ #none.
- ""
- vertices := Array
- with: 5 @ 0
- with: 20 @ 10
- with: 0 @ 20.
- closed := true.
- smoothCurve := false.
- arrows := #none.
self computeBounds!
Item was changed:
----- Method: PolygonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
+ "Handle a mouse-down event."
+ ^ (evt shiftPressed and: [(self hasProperty: #activateOnShift) not])
- ^ 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 changed:
----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') -----
openOrClosePhrase
+ "Answer a string indicating whether the receiver is open or closed."
+
+ ^ (closed ifTrue: ['<yes>'] ifFalse: ['<no>']), 'closed' translated!
- | 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 changed:
----- Method: PolygonMorph>>stepTime (in category 'testing') -----
stepTime
+ "Answer the desired time between steps in milliseconds."
+ ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [100]
+
+ "NB: in all currently known cases, polygons are not actually wrapped in TransformationMorphs, so the #topRendererOrSelf call above is probably redundant, but is retained for safety."!
- ^ 100!
Item was changed:
----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') -----
+ verticesAt: anInteger put: aPoint
+
+ self vertices at: anInteger put: aPoint asFloatPoint.
- verticesAt: ix put: newPoint
- vertices at: ix put: newPoint.
self computeBounds!
Item was changed:
----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') -----
allCurrentlyTickingScriptInstantiations
+ "Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking."
+
+ ^ Array streamContents:
+ [:aStream |
+ self allExtantPlayers do:
+ [:aPlayer | aPlayer instantiatedUserScriptsDo:
+ [:aScriptInstantiation |
+ aScriptInstantiation status == #ticking ifTrue:
+ [aStream nextPut: aScriptInstantiation]]]]!
- ^#()!
Item was changed:
----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') -----
+ browseAllScriptsTextually
+ "Open a method-list browser on all the scripts in the project"
+
+ | aList aMethodList |
+ self flushPlayerListCache. "Just to be certain we get everything"
+
+ (aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players' translated].
+ aMethodList _ OrderedCollection new.
+ aList do:
+ [:aPair | aPair first addMethodReferencesTo: aMethodList].
+ aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!' translated].
+
+ SystemNavigation new
+ browseMessageList: aMethodList
+ name: 'All scripts in this project'
+ autoSelect: nil
+
+ "
+ ActiveWorld presenter browseAllScriptsTextually
+ "!
- browseAllScriptsTextually!
Item was changed:
----- Method: Presenter>>viewMorph: (in category 'stubs') -----
+ viewMorph: aMorph
+ | aPlayer aViewer aPalette aRect aPoint nominalHeight aFlapTab topItem flapLoc |
+ aMorph
+ allMorphsWithPlayersDo: [:mwp :p | (mwp ~~ aMorph
+ and: [mwp wantsConnectionWhenEmbedded])
+ ifTrue: [self viewMorph: mwp]].
+ Sensor leftShiftDown
+ ifFalse: [((aPalette := aMorph standardPalette) notNil
+ and: [aPalette isInWorld])
+ ifTrue: [^ aPalette viewMorph: aMorph]].
+ aPlayer := (topItem := aMorph topRendererOrSelf) assuredPlayer.
+ aViewer := aPlayer allOpenViewers
+ at: 1
+ ifAbsent: [self nascentPartsViewerFor: aPlayer].
+ self cacheSpecs: topItem.
+ flapLoc := associatedMorph.
+ Preferences viewersInFlaps
+ ifTrue: [aViewer owner
+ ifNotNilDo: [:f |
+ f dropEnabled: false.
+ f flapTab
+ ifNotNilDo: [:aFlap | ^ aFlap showFlap; yourself]].
+ aViewer setProperty: #noInteriorThumbnail toValue: true.
+ aViewer initializeFor: aPlayer barHeight: 0.
+ aViewer enforceTileColorPolicy.
+ aViewer fullBounds.
+ flapLoc hideViewerFlapsOtherThanFor: aPlayer.
+ aFlapTab := flapLoc viewerFlapTabFor: topItem.
+
+ aViewer visible: true.
+ aFlapTab applyThickness: aViewer width.
+ aFlapTab spanWorld.
+ aFlapTab showFlap.
+ aViewer position: aFlapTab referent position.
+
+ aFlapTab referent submorphs
+ do: [:m | (m isKindOf: Viewer)
+ ifTrue: [m delete]].
+
+ aFlapTab referent addMorph: aViewer beSticky.
+ flapLoc startSteppingSubmorphsOf: aFlapTab.
+ flapLoc startSteppingSubmorphsOf: aViewer.
+ aFlapTab referent dropEnabled: false.
+ aFlapTab dropEnabled: false.
+ aViewer dropEnabled: false.
+ ^ aFlapTab].
+ aViewer initializeFor: aPlayer barHeight: 6.
+ aViewer enforceTileColorPolicy.
+ aViewer fullBounds.
+ Preferences automaticViewerPlacement
+ ifTrue: [aPoint := aMorph bounds right @ (aMorph center y - ((nominalHeight := aViewer initialHeightToAllow) // 2)).
+ aRect := (aPoint extent: aViewer width @ nominalHeight)
+ translatedToBeWithin: flapLoc bounds.
+ aViewer position: aRect topLeft.
+ aViewer visible: true.
+ associatedMorph addMorph: aViewer.
+ flapLoc startSteppingSubmorphsOf: aViewer.
+ ^ aViewer].
+ aMorph primaryHand
+ attachMorph: (aViewer visible: true).
+ ^ aViewer!
- viewMorph: aMorph
- aMorph inspect.
- !
Item was changed:
----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'ProjectView' translatedNoop!
- ^ 'ProjectView'!
Item was changed:
----- 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' translatedNoop
- label: 'load as project'
selector: #openFromDirectoryAndFileName:
+ description: 'open project from file' translatedNoop
+ buttonLabel: 'load' translatedNoop
- description: 'open project from file'
- buttonLabel: 'load'
)
argumentGetter: [ :fileList | fileList dirAndFileName]!
Item was changed:
----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
+ "Accept -- in a custom sense here -- a morph dropped on the receiver."
| 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 dropEnabled ifFalse:
+ [^ 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.
- 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 changed:
----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
dismissViaHalo
+ "The user clicked on the dismiss icon on the halo."
+
| choice |
+ project ifNil: [^ self delete]. "no current project"
+ choice := (PopUpMenu labelArray:{
+ 'yes - delete icon and remove the project' translated.
+ 'no - delete icon but keep the project' translated.
+ 'cancel - do not delete anything' translated.
+ }) startUpWithCaption: ('Do you really want to delete the
+ project named {1}
+ and all its contents?' translated format: {project name printString}).
+ choice = 1 ifTrue: [^ self expungeProject].
+ choice = 2 ifTrue: [^ self delete]!
- 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 changed:
----- Method: ProjectViewMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
+ | font projectName rectForName measure |
- | font projectName nameForm rectForName |
self ensureImageReady.
super drawOn: aCanvas.
self isEditingName ifTrue: [^self].
+ font _ self fontForName.
+ projectName _ self safeProjectName.
+ (projectName endsWith: '.pr') ifTrue: [
+ projectName _ projectName copyFrom: 1 to: projectName size - 3].
+ (string isNil or: [string contents ~= projectName]) ifTrue: [
+ string := StringMorph contents: projectName font: font.
- font := self fontForName.
- projectName := self safeProjectName.
- nameForm := (StringMorph contents: projectName font: font) imageForm.
- nameForm := nameForm scaledToSize: (self extent - (4@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.
].
+ measure := string measureContents.
+ rectForName _ self bottomLeft +
+ (self width - measure x // 2 @ (measure y + 2) negated)
+ extent: measure.
+ aCanvas clipBy: self bounds during: [:cc |
+ cc fillRectangle: (rectForName outsetBy: (1@1)) color: self colorAroundName.
+ string position: rectForName topLeft.
+ string drawOn: cc
+ ].
- aCanvas
- drawImage: nameForm
- at: rectForName topLeft
!
Item was changed:
----- 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' translated
- ^self inform: 'The project is not present and may not be renamed now'
].
self addProjectNameMorph launchMiniEditor: evt.!
Item was changed:
----- 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' translated]].
- 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 changed:
----- Method: ProjectViewMorph>>fontForName (in category 'drawing') -----
fontForName
+ ^(TextStyle default fontOfSize: 15) emphasized: 1
- | 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 changed:
----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver."
+
super initialize.
+ "currentBorderColor _ Color gray."
+ self addProjectNameMorphFiller.
+ self enableDragNDrop: true.
+ self isOpaque: true.
+ !
- "currentBorderColor := Color gray."
- self addProjectNameMorphFiller.!
Item was changed:
----- Method: ProjectViewMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
- 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.
+ mouseDownTime _ nil.
+ string := nil.
- project := project. "Weakly copied"
- lastProjectThumbnail := lastProjectThumbnail veryDeepCopyWith: deepCopier.
!
Item was changed:
----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
+ "Answer if the receiver would accept a drop of a given morph."
+ "If drop-enabled not set, answer false"
+ (super wantsDroppedMorph: aMorph event: evt) ifFalse: [^ false].
+
+ "If project not present, not morphic, or not initialized, answer false"
+ self isTheRealProjectPresent ifFalse: [^ false].
+ project isMorphic ifFalse: [^ false].
+ project world viewBox ifNil: [^ false].
+
+ ^ true!
- self isTheRealProjectPresent ifFalse: [^false].
- project isMorphic ifFalse: [^false].
- project world viewBox ifNil: [^false]. "uninitialized"
- ^true!
Item was changed:
----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Rectangle' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'A rectangular shape, with border and fill style' translatedNoop!
- ^ self partName: 'Rectangle'
- categories: #('Graphics' 'Basic')
- documentation: 'A rectangular shape, with border and fill style'!
Item was changed:
----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') -----
roundRectPrototype
+ "Answer a prototypical RoundRect object for a parts bin."
+
^ self authoringPrototype useRoundedCorners
+ color: (Color r: 1.0 g: 0.3 b: 0.6);
- color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5);
borderWidth: 1;
setNameTo: 'RoundRect'!
Item was changed:
----- 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].
+ (self valueOfProperty: #withMenuButton) == false ifTrue: [^ nil].
+ menu _ MenuMorph new defaultTarget: model.
+ aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
- menu := MenuMorph new defaultTarget: model.
- aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
getMenuSelector numArgs = 1 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu.
- [aMenu := model perform: getMenuSelector with: menu.
aTitle ifNotNil: [aMenu addTitle: aTitle].
^ aMenu].
getMenuSelector numArgs = 2 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
- [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 changed:
----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Selection' translatedNoop!
- ^ 'Selection'!
Item was changed:
----- 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}.
+ #-.
+ {'distribute vertically' translated. #distributeVertically}.
+ {'distribute horizontally' translated. #distributeHorizontally}.
+ }
- }.
+
- self selectedItems size > 2
- ifTrue:[
- aMenu addList: {
- #-.
- {'distribute vertically' translated. #distributeVertically}.
- {'distribute horizontally' translated. #distributeHorizontally}.
- }.
- ].
!
Item was changed:
----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
+ selectedItems do: [:m | m dismissViaHalo].
-
super dismissViaHalo.
+ !
- selectedItems do: [:m | m dismissViaHalo]!
Item was changed:
----- Method: SelectionMorph>>extent: (in category 'geometry') -----
extent: newExtent
+ "Set the receiver's extent Extend or contract the receiver's selection to encompass morphs within the new extent."
super extent: newExtent.
+ self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])!
- self selectSubmorphsOf: self pasteUpMorph!
Item was changed:
----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: evt
+ "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
selectedItems isEmpty ifTrue:
["Hand just clicked down to draw out a new selection"
^ self extendByHand: evt hand].
+ dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
- 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)] fixTemps].
+ selectedItems _ nil.
+ self removeHalo.
+ self halo ifNotNil: [self halo visible: false].
+ self delete.
- (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
evt wasHandled: true!
Item was changed:
----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') -----
selectSubmorphsOf: aMorph
+ "Given the receiver's current bounds, select submorphs of the indicated pasteup morph that fall entirely within those bounds. If nobody is within the bounds, delete the receiver."
| newItems removals |
+ newItems _ aMorph submorphs select:
- newItems := aMorph submorphs select:
[:m | (bounds containsRect: m fullBounds)
and: [m~~self
and: [(m isKindOf: HaloMorph) not]]].
+ otherSelection ifNil: [^ selectedItems _ newItems].
- otherSelection ifNil: [^ selectedItems := newItems].
+ removals _ newItems intersection: itemsAlreadySelected.
- removals := newItems intersection: itemsAlreadySelected.
otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
+ selectedItems _ (newItems copyWithoutAll: removals).
+ selectedItems ifEmpty: [self delete]
- selectedItems := (newItems copyWithoutAll: removals).
!
Item was changed:
----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') -----
slideToTrash: evt
self delete.
+ "selectedItems do: [:m | m slideToTrash: evt]"!
- selectedItems do: [:m | m slideToTrash: evt]!
Item was changed:
----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
hasContentsInExplorer
+ ^self notEmpty!
- ^self isEmpty not!
Item was changed:
----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
^ self = SimpleButtonMorph
+ ifTrue: ['Button' translatedNoop]
- ifTrue: ['Button']
ifFalse: [^ super defaultNameStemForInstances]!
Item was changed:
----- 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 action selector' translated action: #setActionSelector.
aCustomMenu add: 'change arguments' translated action: #setArguments.
aCustomMenu add: 'change when to act' translated action: #setActWhen.
+ aCustomMenu add: 'set target' translated action: #sightTargets:.
+ target ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]].
- self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
!
Item was changed:
----- 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:
+ [target perform: actionSelector withArguments: arguments].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments]].
actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]!
Item was changed:
----- 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."
+ ^ super 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.
+ Feb 2007: It seems unlikely that Squeak Pages will be used in the OLPC image. Don't use this code. Consider removing all code that supports SqueakPages."
+ "
| bb thatPage um stem ind sqPg |
(actionSelector == #goToPageMorph:fromBookmark:) |
(actionSelector == #goToPageMorph:) ifFalse: [
+ ^ super objectForDataStream: refStrm]. 'normal case'.
- ^ super objectForDataStream: refStrm]. "normal case"
+ target url ifNil: ['Later force target book to get a url.'.
+ bb _ SimpleButtonMorph new. 'write out a dummy'.
- 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.
- (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.
- 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.
- 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'.
- 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
+ "!
- ^ um!
Item was changed:
----- Method: SimpleButtonMorph>>updateVisualState: (in category 'visual properties') -----
updateVisualState: evt
oldColor ifNotNil: [
self color:
((self containsPoint: evt cursorPoint)
+ ifTrue: [oldColor mixed: 0.5 with: Color white]
- ifTrue: [oldColor mixed: 1/2 with: Color white]
ifFalse: [oldColor])]
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ self setProperty: #autoExpand toValue: false.
self
on: #mouseMove
send: #mouseStillDown:onItem:
to: self!
Item was changed:
----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Sketch' translatedNoop!
- ^ 'Sketch'!
Item was changed:
----- Method: SketchMorph>>addToggleItemsToHaloMenu: (in category 'menus') -----
addToggleItemsToHaloMenu: aCustomMenu
+ "Add toggle-items to the halo menu"
+
- "Add toggle-items to the halo menu"
super addToggleItemsToHaloMenu: aCustomMenu.
+ (Smalltalk includesKey: #B3DRenderEngine) ifTrue: [
+ aCustomMenu addUpdating: #useInterpolationString target: self action: #toggleInterpolation.
+ ].
+ !
- Preferences noviceMode
- ifFalse: [""aCustomMenu
- addUpdating: #useInterpolationString
- target: self
- action: #toggleInterpolation]!
Item was changed:
----- Method: SketchMorph>>collapse (in category 'menus') -----
collapse
+ "Replace the receiver with a collapsed rendition of itself."
-
- | priorPosition w collapsedVersion a |
+ | w collapsedVersion a ht tab |
+
+ (w _ self world) ifNil: [^self].
+ collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
- (w := self world) ifNil: [^self].
- collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph.
collapsedVersion setProperty: #uncollapsedMorph toValue: self.
collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
+
+ collapsedVersion setBalloonText: ('A collapsed version of {1}. Click to open it back up.' translated format: {self externalName}).
+
- collapsedVersion setBalloonText: 'A collapsed version of ',self name.
-
self delete.
w addMorphFront: (
+ a _ AlignmentMorph newRow
- a := AlignmentMorph newRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 4;
borderColor: Color white;
+ addMorph: collapsedVersion;
+ yourself).
+ a setNameTo: self externalName.
+ ht := (tab := ActiveWorld findA: SugarNavTab)
+ ifNotNil:
+ [tab height]
+ ifNil:
+ [80].
+ a position: 0@ht.
+
- addMorph: collapsedVersion
- ).
collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+ (self valueOfProperty: #collapsedPosition) ifNotNilDo:
+ [:priorPosition |
+ a position: priorPosition]!
- (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil])
- ifNotNil:
- [a position: priorPosition].
- !
Item was changed:
----- 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 x = 0 or: [newExtent y = 0]) ifTrue: [ ^self ].
- newExtent isZero ifTrue: [ ^self ].
self extent = newExtent ifTrue:[^self].
self scalePoint: newExtent asFloatPoint / (originalForm extent max: 1@1).
self layoutChanged.
!
Item was changed:
----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') -----
flipHorizontal
+ | r |
+ r _ self rotationCenter.
+ self left: self left - (1.0 - (2 * r x) * self width).
+ self form: (self form flipBy: #horizontal centerAt: self form center).
+ self rotationCenter: (1 - r x) @ (r y).!
- self form: (self form flipBy: #horizontal centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>flipVertical (in category 'e-toy support') -----
flipVertical
+ | r |
+ r _ self rotationCenter.
+ self top: self top - (1.0 - (2 * r y) * self height).
+ self form: (self form flipBy: #vertical centerAt: self form center).
+ self rotationCenter: r x @ (1 - r y).!
- self form: (self form flipBy: #vertical centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>initializeWith: (in category 'initialization') -----
initializeWith: aForm
super initialize.
+ originalForm _ aForm.
+ rotationStyle _ #normal. "styles: #normal, #leftRight, #upDown, or #none"
+ scalePoint _ 1.0(a)1.0.
+ framesToDwell _ 1.
+ rotatedForm _ originalForm. "cached rotation of originalForm"
- originalForm := aForm.
- self rotationCenter: 0.5(a)0.5. "relative to the top-left corner of the Form"
- rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none"
- scalePoint := 1.0(a)1.0.
- framesToDwell := 1.
- rotatedForm := originalForm. "cached rotation of originalForm"
self extent: originalForm extent.
!
Item was changed:
----- 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
+ Because my rendering code flips the form (see generateRotatedForm) we 'pre-flip' it here to preserve the same visual appearance.
+ "
- #none -- do not rotate"
+ | wasFlippedX wasFlippedY isFlippedX isFlippedY |
+ wasFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ wasFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ rotationStyle _ aSymbol.
+
+ isFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ isFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ wasFlippedX == isFlippedX
+ ifFalse: [self form: (self form flipBy: #horizontal centerAt: self form center)].
+ wasFlippedY == isFlippedY
+ ifFalse: [self form: (self form flipBy: #vertical centerAt: self form center)].
+
- rotationStyle := aSymbol.
self layoutChanged.
!
Item was changed:
----- Method: Slider>>sliderThickness (in category 'geometry') -----
sliderThickness
+ "^ 7"
+
+ | w |
+ w _ bounds isWide
+ ifTrue: [super height]
+ ifFalse: [super width].
+
+ ^ (w // 32) max: 16.
+ !
- ^ 7!
Item was changed:
----- 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: [FormDictionary at: #Cat]].
+ ^ FormDictionary at: #Cat!
- [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
- ^ nil!
Item was changed:
----- 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.
+ aCustomMenu addUpdating: #usePangoString target: self action: #toggleUsePango.
!
Item was changed:
----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
addOptionalHandlesTo: aHalo box: box
+ "eventually, add more handles for font..."
+
self flag: #deferred.
+ ^ super addOptionalHandlesTo: aHalo box: box
"Eventually...
self addFontHandlesTo: aHalo box: box"!
Item was changed:
----- 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 projectParameterAt: #substitutedFont).
+ (substituteFont notNil and: [self font == substituteFont])
- substituteFont := aProject projectParameters at:
- #substitutedFont ifAbsent: [#none].
- (substituteFont ~~ #none and: [self font == substituteFont])
ifTrue: [ self fitContents ].
^ super fixUponLoad: aProject seg: anImageSegment!
Item was changed:
----- Method: StringMorph>>font: (in category 'printing') -----
font: aFont
"Set the font my text will use. The emphasis remains unchanged."
+ aFont = font ifTrue: [^ self].
+ font _ aFont.
- font := aFont.
^ self font: font emphasis: emphasis!
Item was changed:
----- Method: StringMorphEditor>>initialize (in category 'display') -----
initialize
"Initialize the receiver. Give it a white background"
super initialize.
self backgroundColor: Color white.
+ self textColor: Color red.!
- self color: Color red!
Item was changed:
----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'TrueType banner' translatedNoop
+ categories: #()
+ documentation: 'A short text in a beautiful font. Use the resize handle to change size.' translatedNoop!
- ^ self partName: 'TrueType banner'
- categories: #('Demo')
- documentation: 'A short text in a beautiful font. Use the resize handle to change size.'!
Item was changed:
----- 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' translatedNoop. 'A scrolling data field which will have a different value on every card of the background' translatedNoop}
- 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 changed:
----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') -----
borderedPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t fontName: 'BitstreamVeraSans' pointSize: 24.
t autoFit: false; extent: 250@100.
+ t borderWidth: 1; margins: 4@0; backgroundColor: Color white.
- t borderWidth: 1; margins: 4@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 changed:
----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Text' translatedNoop!
- ^ 'Text'!
Item was changed:
----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') -----
fancyPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t autoFit: false; extent: 150@75.
t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?"
"fancy font, shadow, rounded"
+ t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; fillStyle: Color lightBrown.
- 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 changed:
----- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- 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' translatedNoop. 'A piece of text that will occur on every card of the background' translatedNoop}
- 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' translatedNoop. 'A data field which will have a different value on every card of the background' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you wish' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish')
forFlapNamed: 'Stack Tools'.
+ cl registerQuad: {#TextMorph . #fancyPrototype. 'Fancy Text' translatedNoop. 'A text field with a rounded shadowed border, with a fancy font.' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
forFlapNamed: 'Supplies'.]!
Item was changed:
----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+ (self backgroundColor isNil or: [self backgroundColor asColor isTranslucent])
- (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 changed:
----- Method: TextMorph>>backgroundColor (in category 'accessing') -----
backgroundColor
+ ^ self fillStyle.
+ !
- ^ backgroundColor!
Item was changed:
----- Method: TextMorph>>backgroundColor: (in category 'accessing') -----
backgroundColor: newColor
+ self fillStyle: newColor.
+ !
- backgroundColor := newColor.
- self changed!
Item was changed:
----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
beAllFont: aFont
+ textStyle _ TextStyle fontArray: (Array with: aFont).
+ text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)].
- textStyle := TextStyle fontArray: (Array with: aFont).
self releaseCachedState; changed!
Item was changed:
----- Method: TextMorph>>defaultLineHeight (in category 'geometry') -----
defaultLineHeight
+ ^ ( textStyle fontAt: textStyle defaultFontIndex) pointSize!
- ^ textStyle lineGrid!
Item was changed:
----- Method: TextMorph>>fillStyle: (in category 'visual properties') -----
fillStyle: aFillStyle
"Set the current fillStyle of the receiver."
+ fillStyle _ aFillStyle.
+ backgroundColor _ aFillStyle asColor. "We should get rid of this variable."
- self setProperty: #fillStyle toValue: aFillStyle.
- "Workaround for Morphs not yet converted"
- backgroundColor := aFillStyle asColor.
self changed.!
Item was changed:
----- 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 wid |
- | newExtent para cBounds lastOfLines heightOfLast |
self isAutoFit
ifTrue:
+ [wid _ (text notNil and: [text size > 2]) ifTrue: [5] ifFalse: [40].
+ newExtent := (self paragraph extent max: wid @ ( self defaultLineHeight)) + (0 @ 2).
- [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 changed:
----- Method: TextMorph>>insertCharacters: (in category 'scripting access') -----
+ insertCharacters: aString
- insertCharacters: aSource
"Insert the characters from the given source at my current cursor position"
+ | aLoc aText attributes |
- | aLoc |
aLoc := self cursor max: 1.
+ aText := aLoc > text size
+ ifTrue: [aString asText]
+ ifFalse: [
+ attributes := (text attributesAt: aLoc)
+ select: [:attr | attr mayBeExtended].
+ Text string: aString attributes: attributes].
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aText displaying: true.
- paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
self updateFromParagraph !
Item was changed:
----- 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].
- [paragraph := nil].
container ifNotNil:
+ [container isMorph ifTrue: [container releaseCachedState]]!
- [container releaseCachedState]!
Item was changed:
----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') -----
setAllButFirstCharacter: source
"Set all but the first char of the receiver to the source"
+ | chars |
+ (chars _ self getCharacters) isEmpty
- | aChar chars |
- aChar := source asCharacter.
- (chars := self getCharacters) isEmpty
ifTrue: [self newContents: 'ยท' , source asString]
+ ifFalse: [self newContents: (String
- ifFalse: [chars first = aChar
- ifFalse: [""
- self
- newContents: (String
streamContents: [:aStream |
aStream nextPut: chars first.
+ aStream nextPutAll: source])]!
- aStream nextPutAll: source])]] !
Item was changed:
----- Method: TextMorph>>textColor: (in category 'accessing') -----
textColor: aColor
+ self editor selectFrom: 1 to: 0.
+ self selectionColor: aColor.
- color = aColor ifTrue: [^ self].
- color := aColor.
- self changed.
!
Item was changed:
----- Method: TheWorldMenu>>remoteMenu (in category 'construction') -----
remoteMenu
"Build the Telemorphic menu for the world."
+ ^self fillIn: (self menu: 'Telemorphic' translatedNoop) from: {
+ { 'local host address' translatedNoop. { #myWorld . #reportLocalAddress } }.
+ { 'connect remote user' translatedNoop. { #myWorld . #connectRemoteUser } }.
+ { 'disconnect remote user' translatedNoop. { #myWorld . #disconnectRemoteUser } }.
+ { 'disconnect all remote users' translatedNoop. { #myWorld . #disconnectAllRemoteUsers } }.
- ^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 changed:
----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') -----
windowsMenu
"Build the windows menu for the world."
+ ^ self fillIn: (self menu: 'windows' translatedNoop) from: {
+ { 'find window' translatedNoop. { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' translatedNoop}.
- ^ 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...' translatedNoop. { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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...' translatedNoop. { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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.' translatedNoop}.
- tile: new windows positioned so that they do not overlap others, if possible.'}.
nil.
+ { 'collapse all windows' translatedNoop. { #myWorld . #collapseAllWindows }. 'Reduce all open windows to collapsed forms that only show titles.' translatedNoop}.
+ { 'collapse all objects' translatedNoop. { #myWorld . #collapseAllWindowsAndNonWindows }. 'Reduce all open windows and all other objects on the desktop to labeled tabs' translatedNoop}.
+ { 'expand all' translatedNoop. { #myWorld . #expandAllCollapsedObjects }. 'Expand all collapsed windows and other collapsed objects back to their expanded forms.' translatedNoop}.
+
+ { 'close top window (w)' translatedNoop. { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.' translatedNoop}.
+ { 'send top window to back (\)' translatedNoop. { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.' translatedNoop}.
+ { 'move windows onscreen' translatedNoop. { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen' translatedNoop}.
- { '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' translatedNoop. { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.' translatedNoop}.
+ { 'delete non-windows' translatedNoop. { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.' translatedNoop}.
+ { 'delete both of the above' translatedNoop. { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' translatedNoop}.
- { '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 changed:
----- 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."
+ | args |
(target notNil and: [actionSelector notNil])
ifTrue:
+ [args := actionSelector numArgs > arguments size
+ ifTrue:
+ [arguments copyWith: ActiveEvent]
+ ifFalse:
+ [arguments].
+ Cursor normal
+ showWhile: [target perform: actionSelector withArguments: args].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments].
target isMorph ifTrue: [target changed]]!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| now dt |
- self state: #pressed.
actWhen == #buttonDown
+ ifTrue: [self doButtonAction].
+ actWhen == #buttonUp
+ ifTrue: [self state: #pressed].
+ actWhen == #whilePressed
+ ifTrue:
+ [self state: #pressed.
+ now _ Time millisecondClockValue.
- 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"
+ "NOTE: this delay is temporary disabled because it makes event reaction delay,
+ e.g. the action is not stopped even if you release the button... - Takashi"
+ [dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
+ self mouseStillDown: evt].
+ super mouseDown: evt!
- dt := Time millisecondClockValue - now max: 0. "Time it took to do"
- dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
- self mouseStillDown: evt.!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ (#(#buttonUp #whilePressed ) includes: actWhen)
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #pressed]
+ ifFalse: [self state: #off]].
+ super mouseMove: evt!
- 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 changed:
----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
- mouseUp: evt
"Allow on:send:to: to set the response to events other than actWhen"
+ actWhen == #buttonDown
+ ifTrue: [super mouseUp: evt].
+ actWhen == #buttonUp
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #on.
+ self doButtonAction: evt.
+ super mouseUp: evt]
+ ifFalse: [self state: #off.
+ target
+ ifNotNil: ["Allow owner to keep it selected for radio
+ buttons"
+ target mouseUpBalk: evt]]].
+ actWhen == #whilePressed
+ ifTrue: [self state: #off.
+ super mouseUp: evt]!
- 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 changed:
----- 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: [1]
- ifTrue: [ 2]
ifFalse: [1]!
Item was changed:
----- Method: UpdatingStringMorph>>decimalPlaces (in category 'accessing') -----
decimalPlaces
"Answer the number of decimal places to show."
| places |
+ (places _ decimalPlaces) ifNotNil: [^ places].
+ self decimalPlaces: (places _ Utilities decimalPlacesForFloatPrecision: self floatPrecision).
- (places := self valueOfProperty: #decimalPlaces) ifNotNil: [^ places].
- self setProperty: #decimalPlaces toValue: (places := Utilities decimalPlacesForFloatPrecision: self floatPrecision).
^ places!
Item was changed:
----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') -----
fitContents
+ | newExtent |
+ newExtent := self measureContents.
+ newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.
- | 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 changed:
----- Method: UpdatingStringMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver to have default values in its instance variables."
- "Initialie the receiver to have default values in its instance
- variables "
super initialize.
""
+ format _ #default.
- format := #default.
"formats: #string, #default"
+ target _ getSelector _ putSelector _ nil.
+ floatPrecision _ 1.
+ growable _ true.
+ stepTime _ nil.
+ autoAcceptOnFocusLoss _ true.
+ minimumWidth _ 8.
+ maximumWidth _ 366!
- target := getSelector := putSelector := nil.
- floatPrecision := 1.
- growable := true.
- stepTime := 50.
- autoAcceptOnFocusLoss := true.
- minimumWidth := 8.
- maximumWidth := 300!
Item was changed:
----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') -----
readFromTarget
"Update my readout from my target"
+ | v ret places |
- | v ret |
(target isNil or: [getSelector isNil]) ifTrue: [^contents].
+ ret _ self checkTarget.
- ret := self checkTarget.
ret ifFalse: [^ '0'].
+ ((target isMorph) or:[target isPlayerLike]) ifTrue:[
+ places _ target decimalPlacesForGetter: getSelector.
+ (places ~= nil and: [ places ~= decimalPlaces ]) ifTrue: [ self decimalPlaces: places ]].
v := target perform: getSelector. "scriptPerformer"
(v isKindOf: Text) ifTrue: [v := v asString].
^self acceptValueFromTarget: v!
Item was changed:
----- 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 := MenuMorph new.
aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
+ 0 to: 10 do:
- 0 to: 5 do:
[:places |
aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
aMenu popUpInWorld!
Item was changed:
----- Method: UpdatingStringMorph>>stepTime (in category 'testing') -----
stepTime
+ ^ stepTime ifNil: [200]
- ^ stepTime ifNil: [50]
!
Item was changed:
----- 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.
+ decimalPlaces _ decimalPlaces veryDeepCopyWith: 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.
!
1
0
Tim Felgentreff uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-tfel.1243.mcz
==================== Summary ====================
Name: Morphic-tfel.1243
Author: tfel
Time: 9 August 2016, 2:23:48.66466 pm
UUID: f1f6611a-842d-2843-92c4-70e3f066b74c
Ancestors: Morphic-tfel.1242
add a flag to allow spawning the color picker morph without a color chart (used in etoys)
=============== Diff against Morphic-mt.1240 ===============
Item was changed:
----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
supplementaryPartsDescriptions
"Extra items for parts bins"
^ {DescriptionForPartsBin
+ formalName: 'Circle' translatedNoop
+ categoryList: {'Graphics' translatedNoop}
+ documentation: 'A circular shape' translatedNoop
- formalName: 'Circle1'
- categoryList: #('Graphics')
- documentation: 'A circular shape'
globalReceiverSymbol: #CircleMorph
nativitySelector: #newStandAlone.
+ DescriptionForPartsBin
+ formalName: 'Pin' translatedNoop
+ categoryList: {'Connectors' translatedNoop}
+ documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop
- "DescriptionForPartsBin
- formalName: 'Pin'
- categoryList: #('Connectors')
- documentation: 'An attachment point for Connectors that you can embed in another Morph.'
globalReceiverSymbol: #NCPinMorph
+ nativitySelector: #newPin.
- nativitySelector: #newPin."
}!
Item was changed:
SketchMorph subclass: #ColorPickerMorph
+ instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency noChart'
+ classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransparentBox TransText'
- 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 changed:
----- 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 @ 31. "<<<< the form was changed a bit??"
- 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 changed:
----- 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 insetBy: 2) fillColor: feedbackColor.
- originalForm fill: FeedbackBox fillColor: feedbackColor.
self form: originalForm.
+ selectedColor _ aColor.
- selectedColor := aColor.
updateContinuously ifTrue: [self updateTargetColor].
self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).!
Item was changed:
----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Ellipse' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'An elliptical or circular shape' translatedNoop!
- ^ self partName: 'Ellipse'
- categories: #('Graphics' 'Basic')
- documentation: 'An elliptical or circular shape'!
Item was changed:
----- Method: HaloMorph>>addDupHandle: (in category 'handles') -----
addDupHandle: haloSpec
"Add the halo that offers duplication, or, when shift is down, make-sibling"
+ | aSelector |
+ aSelector := innerTarget couldMakeSibling
+ ifTrue:
+ [#doDupOrMakeSibling:with:]
+ ifFalse:
+ [#doDup:with:].
- self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self
+ self addHandle: haloSpec on: #mouseDown send: aSelector to: self
+
!
Item was changed:
----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') -----
addHandlesForWorldHalos
"Add handles for world halos, like the man said"
| box w |
+ w _ self world ifNil:[target world].
- w := self world ifNil:[target world].
self removeAllMorphs. "remove old handles, if any"
self bounds: target bounds.
+ box _ w bounds insetBy: self handleSize // 2.
- box := w bounds insetBy: 9.
target addWorldHandlesTo: self box: box.
Preferences uniqueNamesInHalos ifTrue:
[innerTarget assureExternalName].
self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
+ growingOrRotating _ false.
- growingOrRotating := false.
self layoutChanged.
self changed.
!
Item was changed:
----- Method: HaloMorph>>addViewingHandle: (in category 'handles') -----
addViewingHandle: haloSpec
+ "If appropriate, add a special Viewing halo handle to the receiver. On 26 Sept 07, we decided to eliminate this item from the UI, so the code of is method is now commented out...
- "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 changed:
----- Method: HaloMorph>>basicBox (in category 'private') -----
basicBox
| aBox minSide anExtent w |
+ minSide _ 4 * self handleSize.
+ anExtent _ ((self width + self handleSize + 8) max: minSide) @
- 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].
- aBox := Rectangle center: self center extent: anExtent.
- w := self world ifNil:[target outermostWorldMorph].
^ w
ifNil:
[aBox]
ifNotNil:
+ [aBox intersect: (w viewBox insetBy: self handleSize // 2)]
- [aBox intersect: (w viewBox insetBy: 8@8)]
!
Item was changed:
----- Method: HaloMorph>>doDirection:with: (in category 'private') -----
doDirection: anEvent with: directionHandle
+ "The mouse went down on the forward-direction halo handle; respond appropriately."
+
anEvent hand obtainHalo: self.
+ anEvent shiftPressed
+ ifTrue:
+ [directionArrowAnchor _ (target point: target referencePosition in: self world) rounded.
+ self positionDirectionShaft: directionHandle.
+ self removeAllHandlesBut: directionHandle.
+ directionHandle setProperty: #trackDirectionArrow toValue: true]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: directionHandle]!
- self removeAllHandlesBut: directionHandle!
Item was changed:
----- Method: HaloMorph>>handleSize (in category 'private') -----
handleSize
^ Preferences biggerHandles
+ ifTrue: [30]
- ifTrue: [20]
ifFalse: [16]!
Item was changed:
----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') -----
prepareToTrackCenterOfRotation: evt with: rotationHandle
+ "The mouse went down on the center of rotation."
+
evt hand obtainHalo: self.
+ evt shiftPressed
+ ifTrue:
+ [self removeAllHandlesBut: rotationHandle.
+ rotationHandle setProperty: #trackCenterOfRotation toValue: true.
+ evt hand showTemporaryCursor: Cursor blank]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: rotationHandle]!
- evt shiftPressed ifTrue:[
- self removeAllHandlesBut: rotationHandle.
- ] ifFalse:[
- rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
- self startDrag: evt with: rotationHandle
- ].
- evt hand showTemporaryCursor: Cursor blank!
Item was changed:
----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') -----
setCenterOfRotation: evt with: rotationHandle
| localPt |
evt hand obtainHalo: self.
evt hand showTemporaryCursor: nil.
+ (rotationHandle hasProperty: #trackCenterOfRotation) ifTrue:
+ [localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
+ innerTarget setRotationCenterFrom: localPt].
+
+ rotationHandle removeProperty: #trackCenterOfRotation.
+ self endInteraction!
- (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
- localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
- innerTarget setRotationCenterFrom: localPt.
- ].
- rotationHandle removeProperty: #dragByCenterOfRotation.
- self endInteraction
- !
Item was changed:
----- 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"
+ (directionHandle hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ target setDirectionFrom: directionHandle center.
+ directionHandle removeProperty: #trackDirectionArrow.
+ self endInteraction]!
- anEvent hand obtainHalo: self.
- target setDirectionFrom: directionHandle center.
- self endInteraction!
Item was changed:
----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') -----
trackCenterOfRotation: anEvent with: rotationHandle
(rotationHandle hasProperty: #dragByCenterOfRotation)
ifTrue:[^self doDrag: anEvent with: rotationHandle].
+ (rotationHandle hasProperty: #trackCenterOfRotation)
+ ifTrue:
+ [anEvent hand obtainHalo: self.
+ rotationHandle center: anEvent cursorPoint]!
- anEvent hand obtainHalo: self.
- rotationHandle center: anEvent cursorPoint.!
Item was changed:
----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') -----
trackDirectionArrow: anEvent with: shaft
+ (shaft hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
+ self layoutChanged]!
- anEvent hand obtainHalo: self.
- shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
- self layoutChanged!
Item was changed:
----- Method: HandleMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self extent: 16 @ 16.
- self extent: 8 @ 8.
!
Item was changed:
----- Method: IconicButton>>stationarySetup (in category 'initialization') -----
stationarySetup
+ "Set up event handlers for mouse actions. Should be spelled stationery..."
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.
+
+ self on: #click send: #launchPartFromClick to: self!
- self on: #mouseUp send: #borderThick to: self.!
Item was changed:
----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Image' translatedNoop
+ categories: #()
+ documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.' translatedNoop!
- ^ 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 changed:
----- 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' translatedNoop. 'A non-editable picture of something' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Joystick' translatedNoop
+ categories: {'Basic' translatedNoop}
+ documentation: 'A joystick-like control' translatedNoop!
- ^ self partName: 'Joystick'
- categories: #('Useful')
- documentation: 'A joystick-like control'!
Item was changed:
----- 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' translatedNoop. 'A joystick-like control' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Scripting'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ "Answer a description for the parts bin."
+
+ ^ self partName: 'Line' translatedNoop
+ categories: {'Graphics' translatedNoop}
+ documentation: 'A straight line. Shift-click to get handles and move the ends.' translatedNoop!
- ^ self partName: 'Line'
- categories: #('Graphics' 'Basic')
- documentation: 'A straight line. Shift-click to get handles and move the ends.'!
Item was changed:
----- 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.
- ActiveWorld addMorph: self centeredNear: aPoint.
self world displayWorld. "show myself"
+ aBlock value]
+ ensure: [self delete]!
- aBlock value.
- self delete!
Item was changed:
----- Method: MenuIcons class>>iconForMenuItem: (in category 'menu decoration') -----
iconForMenuItem: anItem
+ "Answer the icon (or nil) corresponding to a given menu item."
- "Answer the icon (or nil) corresponding to the (translated) string."
+ | aKey |
+ aKey _ (anItem selector == #undoOrRedoCommand)
+ ifTrue:
+ ['undo (z)' translated] "Actual wording changes dynamically"
+ ifFalse:
+ [anItem contents asString].
+ ^ TranslatedIcons at: aKey asLowercase ifAbsent: [nil]!
- ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]!
Item was changed:
----- Method: MenuMorph>>delete (in category 'initialization') -----
delete
+ "Delete the receiver."
+
+ activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]].
+ self isFlexed ifTrue: [^ owner delete].
+ ^ super delete!
- activeSubMenu ifNotNil:[activeSubMenu delete].
- ^super delete!
Item was changed:
----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') -----
serviceLoadMorphFromFile
"Answer a service for loading a .morph file"
^ SimpleServiceEntry
provider: self
+ label: 'load as morph' translatedNoop
- label: 'load as morph'
selector: #fromFileName:
+ description: 'load as morph' translatedNoop
+ buttonLabel: 'load' translatedNoop!
- description: 'load as morph'
- buttonLabel: 'load'!
Item was changed:
----- 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 w |
+ menu _ MenuMorph new defaultTarget: self.
+ w _ self world.
+ self potentialEmbeddingTargets reverseDo: [:m |
+ menu add: (m == w ifTrue: ['desktop' translated] ifFalse: [m knownName ifNil:[m class name asString]]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}.
+ m == self topRendererOrSelf owner ifTrue:
+ [menu lastItem color: Color red]].
+ aMenu ifNotNil:
+ [menu submorphCount > 0
+ ifTrue:[aMenu add:'embed into' translated subMenu: 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 changed:
----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') -----
addFlexShell
"Wrap a rotating and scaling shell around this morph."
+ | oldHalo flexMorph myWorld anIndex morphOwner |
- | oldHalo flexMorph myWorld anIndex |
myWorld := self world.
+ oldHalo:= self halo.
+ self owner ifNotNil:[ morphOwner := self owner]
+ ifNil:[morphOwner := self currentWorld].
+
+ anIndex := morphOwner submorphIndexOf: self.
+ morphOwner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self)
- 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 changed:
----- Method: Morph>>addHaloActionsTo: (in category 'menus') -----
addHaloActionsTo: aMenu
"Add items to aMenu representing actions requestable via halo"
| subMenu |
+ subMenu _ MenuMorph new defaultTarget: self.
- 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 add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles.
subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.
+ subMenu add: 'tile representing this object' translated target: self action: #tearOffTile.
- 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 changed:
----- 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 notNil and: [aNumber <= submorphs size])
- (aNumber <= submorphs size)
ifTrue:
[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
ifFalse:
+ [self addMorphBack: aMorph]!
- [self addMorphBack: aMorph]
- !
Item was changed:
----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') -----
chooseNewGraphicCoexisting: aBoolean
"Allow the user to choose a different form for her form-based morph"
+
| replacee aGraphicalMenu |
+ self isInWorld ifFalse: "menu must have persisted for a not-in-world object."
+ [aGraphicalMenu := ActiveWorld submorphThat:
+ [:m | (m isKindOf: GraphicalMenu) and: [m target == self]]
+ ifNone:
+ [^ self].
+ ^ aGraphicalMenu show; flashBounds].
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 changed:
----- Method: Morph>>couldMakeSibling (in category 'testing') -----
couldMakeSibling
"Answer whether it is appropriate to ask the receiver to make a sibling"
+ ^ self isWorldMorph not!
- ^ true!
Item was changed:
----- Method: Morph>>goBehind (in category 'submorphs-add/remove') -----
goBehind
+ "Move the receiver to bottom z-order."
+ | topRend |
+ topRend := self topRendererOrSelf.
+ topRend owner ifNotNilDo:
+ [:own | own addMorphNearBack: topRend]
- owner addMorphNearBack: self.
!
Item was changed:
----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') -----
invokeMetaMenu: evt
+ "Put up the 'meta' menu, invoked via control-click, unless eToyFriendly is true."
+
| menu |
+ Preferences eToyFriendly ifTrue: [^ self].
+
+ menu _ self buildMetaMenu: evt.
- menu := self buildMetaMenu: evt.
menu addTitle: self externalName.
+ menu popUpEvent: evt in: self world!
- self world ifNotNil: [
- menu popUpEvent: evt in: self world
- ]!
Item was changed:
----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') -----
obtrudesBeyondContainer
"Answer whether the receiver obtrudes beyond the bounds of its container"
+ | top formerOwner |
- | top |
top := self topRendererOrSelf.
+ top owner ifNil: [^ false].
+ ^ top owner isHandMorph
+ ifTrue:
+ [((formerOwner := top formerOwner) notNil and: [formerOwner isInWorld])
+ ifFalse:
+ [false]
+ ifTrue:
+ [(formerOwner boundsInWorld containsRect: top boundsInWorld) not]]
+ ifFalse:
+ [(top owner bounds containsRect: top bounds) not]!
- (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
- ^(top owner bounds containsRect: top bounds) not!
Item was changed:
----- Method: Morph>>on:send:to: (in category 'event handling') -----
on: eventName send: selector to: recipient
+ "When the given event occurs, send the given selector to the given recipient. If the given selector is nil, rescind any earlier handling for the given event type,"
+
+ self eventHandler ifNil:
+ [selector ifNil: [^ self]. "Don't pointlessly create an event handler!!"
+ self eventHandler: EventHandler new].
- self eventHandler ifNil: [self eventHandler: EventHandler new].
self eventHandler on: eventName send: selector to: recipient!
Item was changed:
----- Method: Morph>>openViewerForArgument (in category 'player viewer') -----
openViewerForArgument
+ Cursor wait
+ showWhile: [self presenter viewMorph: self]!
- "Open up a viewer for a player associated with the morph in question. "
- self presenter viewMorph: self!
Item was changed:
----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') -----
overlapsShadowForm: itsShadow bounds: itsBounds
"Answer true if itsShadow and my shadow overlap at all"
+ | overlapExtent overlap myRect myShadow goalRect goalShadow bb |
+ overlap _ self fullBounds intersect: itsBounds.
+ overlapExtent _ overlap extent.
- | andForm overlapExtent |
- overlapExtent := (itsBounds intersect: self fullBounds) extent.
overlapExtent > (0 @ 0)
ifFalse: [^ false].
+ myRect := overlap translateBy: 0 @ 0 - self topLeft.
+ myShadow := (self imageForm contentsOfArea: myRect) stencil.
+ goalRect := overlap translateBy: 0 @ 0 - itsBounds topLeft.
+ goalShadow := (itsShadow contentsOfArea: goalRect) stencil.
+
+ "compute a pixel-by-pixel AND of the two stencils. Result will be black
+ (pixel value = 1) where black parts of the stencils overlap"
+ bb := BitBlt toForm: myShadow.
+ bb
+ copyForm: goalShadow
+ to: 0 @ 0
+ rule: Form and.
+
+ ^(bb destForm tallyPixelValues second) > 0 !
- 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 changed:
----- Method: Morph>>roundUpStrays (in category 'miscellaneous') -----
roundUpStrays
+ "Bring submorphs of playfieldlike structures in the receiver's interior back within view."
+
+ self submorphsDo:
+ [:m | m isPlayfieldLike ifTrue: [m roundUpStrays]]!
- self submorphs
- do: [:each | each roundUpStrays]!
Item was changed:
----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
slideBackToFormerSituation: evt
+ "A drop of the receiver having been rejected, slide it back to where it came from, if possible."
+
| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
formerOwner := self formerOwner.
formerPosition := self formerPosition.
+ (aWorld := evt hand world) ifNil: [^ self delete]. "Likely a moribund hand from an EventRecorder playback."
+
- 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.
+ "The OLPC Virtual Screen wouldn't notice the last update here."
+ Display forceToScreen: (endPoint extent: slideForm extent).
formerOwner addMorph: self.
self position: formerPosition.
self justDroppedInto: formerOwner event: evt!
Item was changed:
----- Method: Morph>>useGradientFill (in category 'visual properties') -----
useGradientFill
"Make receiver use a solid fill style (e.g., a simple color)"
+
+ | fill color1 color2 fil |
+ ((fil := self fillStyle) notNil and: [fil isSymbol not] and: [fil isGradientFill]) ifTrue:[^self]. "Already done"
+ color1 _ self color asColor.
+ color2 _ color1 negated.
+ fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
- | 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 changed:
----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') -----
wantsHaloFromClick
+
+ ^ self valueOfProperty: #wantsHaloFromClick ifAbsent: [^true].!
- ^ true!
Item was changed:
----- Method: MorphicProject>>updateLocaleDependents (in category 'language') -----
updateLocaleDependents
"Set the project's natural language as indicated"
ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
viewerOrScriptor localeChanged].
Flaps disableGlobalFlaps: false.
+ (Preferences eToyFriendly or: [Smalltalk globals at: #SugarNavigatorBar ifPresent: [:c | c showSugarNavigator] ifAbsent: [false]])
- Preferences eToyFriendly
ifTrue: [
Flaps addAndEnableEToyFlaps.
ActiveWorld addGlobalFlaps]
ifFalse: [Flaps enableGlobalFlaps].
(Project current isFlapIDEnabled: 'Navigator' translated)
ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].
ScrapBook default emptyScrapBook.
MenuIcons initializeTranslations.
super updateLocaleDependents.
"self setFlaps.
self setPaletteFor: aLanguageSymbol."
!
Item was changed:
----- 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 := 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 wantsMouseOverHalos: false.
proto beSticky.
^ proto!
Item was changed:
----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
"Answer a basis for names of default instances of the receiver"
+ ^ 'playfield' translatedNoop!
- ^ 'playfield'!
Item was changed:
----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') -----
addPenMenuItems: menu hand: aHandMorph
"Add a pen-trails-within submenu to the given menu"
+ menu add: 'pen trails...' translated target: self selector: #putUpPenTrailsSubmenu.
+ menu balloonTextForLastItem: 'its governing pen trails drawn within' translated!
- menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu!
Item was changed:
----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') -----
addPenTrailsMenuItemsTo: aMenu
"Add items relating to pen trails to aMenu"
| oldTarget |
+ oldTarget _ aMenu defaultTarget.
- 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 addLine.
+ aMenu addUpdating: #batchPenTrailsString action: #toggleBatchPenTrails.
+ aMenu balloonTextForLastItem: 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.' translated.
+
aMenu defaultTarget: oldTarget!
Item was changed:
----- Method: PasteUpMorph>>addWorldToggleItemsToHaloMenu: (in category 'menu & halo') -----
addWorldToggleItemsToHaloMenu: aMenu
+ "Add toggle items for the world to the halo menu .... July 2009: no longer in world halo menu"
- "Add toggle items for the world to the halo menu"
+ "aMenu addUpdating: #showTabsString
+ target: CurrentProjectRefactoring
+ action: #currentToggleFlapsSuppressed "!
- #(
- (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 changed:
----- 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.
+ self changed "redraw"
- self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
!
Item was changed:
----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') -----
chooseClickTarget
Cursor crossHair showWhile:
[Sensor waitButton].
Cursor down showWhile:
[Sensor anyButtonPressed].
+ ^ (self morphsAt: Sensor cursorPoint) first topRendererOrSelf!
- ^ (self morphsAt: Sensor cursorPoint) first!
Item was changed:
----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') -----
correspondingFlapTab
+ "If there is a flap tab whose referent is me, return it, else return nil. Will also work for flaps on the edge of embedded subareas such as within scripting-areas, but more slowly."
+
- "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]].
+
+ "Catch guys in embedded worldlets"
+ ActiveWorld allMorphs do:
+ [:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]].
+
^ nil!
Item was changed:
----- 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' translatedNoop]!
- ['world']!
Item was changed:
----- 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@0) anyShapeFill reverse.
+ screenForm _ Form fromDisplay: (topLeft extent: outline extent).
- outline := poly shadowForm.
- topLeft := outline offset.
- exterior := (outline offset: 0@0) anyShapeFill reverse.
- screenForm := Form fromDisplay: (topLeft extent: outline extent).
screenForm eraseShape: exterior.
+ innerForm _ screenForm trimBordersOfColor: Color transparent.
+ ActiveHand showTemporaryCursor: nil.
- innerForm := screenForm trimBordersOfColor: Color transparent.
innerForm isAllWhite ifFalse:
[hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was changed:
----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
flapTab
+ "Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'"
+
| ww |
self isFlap ifFalse:[^nil].
+ ww _ self presenter associatedMorph ifNil: [ActiveWorld].
+ ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]!
- ww := self world ifNil: [World].
- ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]!
Item was changed:
----- 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>'])
+ , 'grid visible when gridding' translated!
- , 'show grid when gridding' translated!
Item was changed:
----- Method: PasteUpMorph>>installFlaps (in category 'world state') -----
installFlaps
"Get flaps installed within the bounds of the receiver"
+ | localFlapTabs |
Project current assureFlapIntegrity.
self addGlobalFlaps.
+ localFlapTabs := self localFlapTabs.
+ localFlapTabs do: [:each | each visible: false].
+
+ Preferences eToyFriendly ifTrue: [
+ ProgressInitiationException display: 'Building Viewers...' translated
+ during: [:bar |
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld.
+ bar value: i / self localFlapTabs size]].
+ ] ifFalse: [
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld]].
+
- self localFlapTabs do:
- [:aFlapTab | aFlapTab adaptToWorld].
self assureFlapTabsFitOnScreen.
self bringTopmostsToFront!
Item was changed:
----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') -----
presentCardAndStackMenu
"Put up a menu holding card/stack-related options."
| aMenu |
+ aMenu _ MenuMorph new defaultTarget: self.
- aMenu := MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
+ aMenu addTitle: 'card and stack' translated.
+ aMenu add: 'add new card' translated action: #insertCard.
+ aMenu add: 'delete this card' translated action: #deleteCard.
+ aMenu add: 'go to next card' translated action: #goToNextCardInStack.
+ aMenu add: 'go to previous card' translated action: #goToPreviousCardInStack.
- 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' translated action: #showForegroundObjects.
+ aMenu add: 'show background objects' translated action: #showBackgroundObjects.
+ aMenu add: 'show designations' translated action: #showDesignationsOfObjects.
+ aMenu add: 'explain designations' translated action: #explainDesignations.
- 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 changed:
----- Method: PasteUpMorph>>referencePool (in category 'objects from disk') -----
referencePool
^ self
valueOfProperty: #References
+ ifAbsentPut: [WeakValueDictionary new]
+ !
- ifAbsentPut: [OrderedCollection new]
-
- !
Item was changed:
----- 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 changed:
----- 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]!
- aPlayer startRunning; step; stopRunning].
-
- self allScriptors do:
- [:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
- !
Item was changed:
----- 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 stopSound.
+ aPlayer stopRunning].
- aPlayer stopRunning].
- self allScriptors do:
- [:aScript | aScript pauseIfTicking].
self world updateStatusForAllScriptEditors!
Item was changed:
----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') -----
triggerClosingScripts
"If the receiver has any scripts set to run on closing, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllClosingScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllClosingScripts]!
Item was changed:
----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') -----
triggerOpeningScripts
"If the receiver has any scripts set to run on opening, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllOpeningScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllOpeningScripts]!
Item was changed:
----- 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:
+ [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]!
- [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 changed:
----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
setTextColor: aColor
"Set the color of my text to the given color"
+ textMorph textColor: aColor!
- textMorph color: aColor!
Item was changed:
----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Polygon' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ 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.' translatedNoop!
- ^ 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 changed:
----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu 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."
+
- addCustomMenuItems: aMenu hand: aHandMorph
- | |
super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles.
+ vertices size > 2 ifTrue:
+ [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed].
+
+ aMenu addUpdating: #smoothPhrase target: self action: #toggleSmoothing.
+ aMenu addLine.
+ aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
+
+ self isOpen ifTrue:
+ [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]].!
- 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 changed:
----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
+
+ ^ Color black
+
+ "Until September 2007, this had long been...
^ Color
r: 0.0
g: 0.419
+ b: 0.935"!
- b: 0.935!
Item was changed:
----- Method: PolygonMorph>>fillStyle (in category 'visual properties') -----
fillStyle
+ "Answer the receiver's fillStyle. For an *open* polygon, we return the borderColor, provided it's a true color rather than something strange like the symbol #raised."
+ | aColor |
self isOpen
+ ifTrue:
+ [(aColor := self borderColor) isColor ifTrue: [^ aColor]]. "easy access to line color from halo -- di's old note"
+
+ ^ super fillStyle!
- ifTrue: [^ self borderColor "easy access to line color from halo"]
- ifFalse: [^ super fillStyle]!
Item was changed:
----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') -----
handlesShowingPhrase
+ "Answer a phrase characterizing whether handles are showing or not."
+
+ ^ (self showingHandles ifTrue: ['<yes>'] ifFalse: ['<no>']), ('show handles' translated)!
- ^ (self showingHandles
- ifTrue: ['hide handles']
- ifFalse: ['show handles']) translated!
Item was changed:
----- Method: PolygonMorph>>initialize (in category 'initialization') -----
initialize
+ "initialize the state of the receiver. This sets up a 4-sided polygon as the default."
+
- "initialize the state of the receiver"
super initialize.
+
+ vertices _ Array
+ with: 15 @ 0
+ with: 45 @ 20
+ with: 60@60
+ with: 0 @ 60.
+ vertexCursor _ 1.
+ closed _ true.
+ smoothCurve _ false.
+ arrows _ #none.
- ""
- vertices := Array
- with: 5 @ 0
- with: 20 @ 10
- with: 0 @ 20.
- closed := true.
- smoothCurve := false.
- arrows := #none.
self computeBounds!
Item was changed:
----- Method: PolygonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
+ "Handle a mouse-down event."
+ ^ (evt shiftPressed and: [(self hasProperty: #activateOnShift) not])
- ^ 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 changed:
----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') -----
openOrClosePhrase
+ "Answer a string indicating whether the receiver is open or closed."
+
+ ^ (closed ifTrue: ['<yes>'] ifFalse: ['<no>']), 'closed' translated!
- | 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 changed:
----- Method: PolygonMorph>>stepTime (in category 'testing') -----
stepTime
+ "Answer the desired time between steps in milliseconds."
+ ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [100]
+
+ "NB: in all currently known cases, polygons are not actually wrapped in TransformationMorphs, so the #topRendererOrSelf call above is probably redundant, but is retained for safety."!
- ^ 100!
Item was changed:
----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') -----
+ verticesAt: anInteger put: aPoint
+
+ self vertices at: anInteger put: aPoint asFloatPoint.
- verticesAt: ix put: newPoint
- vertices at: ix put: newPoint.
self computeBounds!
Item was changed:
----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') -----
allCurrentlyTickingScriptInstantiations
+ "Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking."
+
+ ^ Array streamContents:
+ [:aStream |
+ self allExtantPlayers do:
+ [:aPlayer | aPlayer instantiatedUserScriptsDo:
+ [:aScriptInstantiation |
+ aScriptInstantiation status == #ticking ifTrue:
+ [aStream nextPut: aScriptInstantiation]]]]!
- ^#()!
Item was changed:
----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') -----
+ browseAllScriptsTextually
+ "Open a method-list browser on all the scripts in the project"
+
+ | aList aMethodList |
+ self flushPlayerListCache. "Just to be certain we get everything"
+
+ (aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players' translated].
+ aMethodList _ OrderedCollection new.
+ aList do:
+ [:aPair | aPair first addMethodReferencesTo: aMethodList].
+ aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!' translated].
+
+ SystemNavigation new
+ browseMessageList: aMethodList
+ name: 'All scripts in this project'
+ autoSelect: nil
+
+ "
+ ActiveWorld presenter browseAllScriptsTextually
+ "!
- browseAllScriptsTextually!
Item was changed:
----- Method: Presenter>>viewMorph: (in category 'stubs') -----
+ viewMorph: aMorph
+ | aPlayer aViewer aPalette aRect aPoint nominalHeight aFlapTab topItem flapLoc |
+ aMorph
+ allMorphsWithPlayersDo: [:mwp :p | (mwp ~~ aMorph
+ and: [mwp wantsConnectionWhenEmbedded])
+ ifTrue: [self viewMorph: mwp]].
+ Sensor leftShiftDown
+ ifFalse: [((aPalette := aMorph standardPalette) notNil
+ and: [aPalette isInWorld])
+ ifTrue: [^ aPalette viewMorph: aMorph]].
+ aPlayer := (topItem := aMorph topRendererOrSelf) assuredPlayer.
+ aViewer := aPlayer allOpenViewers
+ at: 1
+ ifAbsent: [self nascentPartsViewerFor: aPlayer].
+ self cacheSpecs: topItem.
+ flapLoc := associatedMorph.
+ Preferences viewersInFlaps
+ ifTrue: [aViewer owner
+ ifNotNilDo: [:f |
+ f dropEnabled: false.
+ f flapTab
+ ifNotNilDo: [:aFlap | ^ aFlap showFlap; yourself]].
+ aViewer setProperty: #noInteriorThumbnail toValue: true.
+ aViewer initializeFor: aPlayer barHeight: 0.
+ aViewer enforceTileColorPolicy.
+ aViewer fullBounds.
+ flapLoc hideViewerFlapsOtherThanFor: aPlayer.
+ aFlapTab := flapLoc viewerFlapTabFor: topItem.
+
+ aViewer visible: true.
+ aFlapTab applyThickness: aViewer width.
+ aFlapTab spanWorld.
+ aFlapTab showFlap.
+ aViewer position: aFlapTab referent position.
+
+ aFlapTab referent submorphs
+ do: [:m | (m isKindOf: Viewer)
+ ifTrue: [m delete]].
+
+ aFlapTab referent addMorph: aViewer beSticky.
+ flapLoc startSteppingSubmorphsOf: aFlapTab.
+ flapLoc startSteppingSubmorphsOf: aViewer.
+ aFlapTab referent dropEnabled: false.
+ aFlapTab dropEnabled: false.
+ aViewer dropEnabled: false.
+ ^ aFlapTab].
+ aViewer initializeFor: aPlayer barHeight: 6.
+ aViewer enforceTileColorPolicy.
+ aViewer fullBounds.
+ Preferences automaticViewerPlacement
+ ifTrue: [aPoint := aMorph bounds right @ (aMorph center y - ((nominalHeight := aViewer initialHeightToAllow) // 2)).
+ aRect := (aPoint extent: aViewer width @ nominalHeight)
+ translatedToBeWithin: flapLoc bounds.
+ aViewer position: aRect topLeft.
+ aViewer visible: true.
+ associatedMorph addMorph: aViewer.
+ flapLoc startSteppingSubmorphsOf: aViewer.
+ ^ aViewer].
+ aMorph primaryHand
+ attachMorph: (aViewer visible: true).
+ ^ aViewer!
- viewMorph: aMorph
- aMorph inspect.
- !
Item was changed:
----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'ProjectView' translatedNoop!
- ^ 'ProjectView'!
Item was changed:
----- 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' translatedNoop
- label: 'load as project'
selector: #openFromDirectoryAndFileName:
+ description: 'open project from file' translatedNoop
+ buttonLabel: 'load' translatedNoop
- description: 'open project from file'
- buttonLabel: 'load'
)
argumentGetter: [ :fileList | fileList dirAndFileName]!
Item was changed:
----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
+ "Accept -- in a custom sense here -- a morph dropped on the receiver."
| 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 dropEnabled ifFalse:
+ [^ 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.
- 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 changed:
----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
dismissViaHalo
+ "The user clicked on the dismiss icon on the halo."
+
| choice |
+ project ifNil: [^ self delete]. "no current project"
+ choice := (PopUpMenu labelArray:{
+ 'yes - delete icon and remove the project' translated.
+ 'no - delete icon but keep the project' translated.
+ 'cancel - do not delete anything' translated.
+ }) startUpWithCaption: ('Do you really want to delete the
+ project named {1}
+ and all its contents?' translated format: {project name printString}).
+ choice = 1 ifTrue: [^ self expungeProject].
+ choice = 2 ifTrue: [^ self delete]!
- 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 changed:
----- Method: ProjectViewMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
+ | font projectName rectForName measure |
- | font projectName nameForm rectForName |
self ensureImageReady.
super drawOn: aCanvas.
self isEditingName ifTrue: [^self].
+ font _ self fontForName.
+ projectName _ self safeProjectName.
+ (projectName endsWith: '.pr') ifTrue: [
+ projectName _ projectName copyFrom: 1 to: projectName size - 3].
+ (string isNil or: [string contents ~= projectName]) ifTrue: [
+ string := StringMorph contents: projectName font: font.
- font := self fontForName.
- projectName := self safeProjectName.
- nameForm := (StringMorph contents: projectName font: font) imageForm.
- nameForm := nameForm scaledToSize: (self extent - (4@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.
].
+ measure := string measureContents.
+ rectForName _ self bottomLeft +
+ (self width - measure x // 2 @ (measure y + 2) negated)
+ extent: measure.
+ aCanvas clipBy: self bounds during: [:cc |
+ cc fillRectangle: (rectForName outsetBy: (1@1)) color: self colorAroundName.
+ string position: rectForName topLeft.
+ string drawOn: cc
+ ].
- aCanvas
- drawImage: nameForm
- at: rectForName topLeft
!
Item was changed:
----- 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' translated
- ^self inform: 'The project is not present and may not be renamed now'
].
self addProjectNameMorph launchMiniEditor: evt.!
Item was changed:
----- 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' translated]].
- 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 changed:
----- Method: ProjectViewMorph>>fontForName (in category 'drawing') -----
fontForName
+ ^(TextStyle default fontOfSize: 15) emphasized: 1
- | 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 changed:
----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver."
+
super initialize.
+ "currentBorderColor _ Color gray."
+ self addProjectNameMorphFiller.
+ self enableDragNDrop: true.
+ self isOpaque: true.
+ !
- "currentBorderColor := Color gray."
- self addProjectNameMorphFiller.!
Item was changed:
----- Method: ProjectViewMorph>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: deepCopier
- 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.
+ mouseDownTime _ nil.
+ string := nil.
- project := project. "Weakly copied"
- lastProjectThumbnail := lastProjectThumbnail veryDeepCopyWith: deepCopier.
!
Item was changed:
----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
+ "Answer if the receiver would accept a drop of a given morph."
+ "If drop-enabled not set, answer false"
+ (super wantsDroppedMorph: aMorph event: evt) ifFalse: [^ false].
+
+ "If project not present, not morphic, or not initialized, answer false"
+ self isTheRealProjectPresent ifFalse: [^ false].
+ project isMorphic ifFalse: [^ false].
+ project world viewBox ifNil: [^ false].
+
+ ^ true!
- self isTheRealProjectPresent ifFalse: [^false].
- project isMorphic ifFalse: [^false].
- project world viewBox ifNil: [^false]. "uninitialized"
- ^true!
Item was changed:
----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Rectangle' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'A rectangular shape, with border and fill style' translatedNoop!
- ^ self partName: 'Rectangle'
- categories: #('Graphics' 'Basic')
- documentation: 'A rectangular shape, with border and fill style'!
Item was changed:
----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') -----
roundRectPrototype
+ "Answer a prototypical RoundRect object for a parts bin."
+
^ self authoringPrototype useRoundedCorners
+ color: (Color r: 1.0 g: 0.3 b: 0.6);
- color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5);
borderWidth: 1;
setNameTo: 'RoundRect'!
Item was changed:
----- 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].
+ (self valueOfProperty: #withMenuButton) == false ifTrue: [^ nil].
+ menu _ MenuMorph new defaultTarget: model.
+ aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
- menu := MenuMorph new defaultTarget: model.
- aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
getMenuSelector numArgs = 1 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu.
- [aMenu := model perform: getMenuSelector with: menu.
aTitle ifNotNil: [aMenu addTitle: aTitle].
^ aMenu].
getMenuSelector numArgs = 2 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
- [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 changed:
----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Selection' translatedNoop!
- ^ 'Selection'!
Item was changed:
----- 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}.
+ #-.
+ {'distribute vertically' translated. #distributeVertically}.
+ {'distribute horizontally' translated. #distributeHorizontally}.
+ }
- }.
+
- self selectedItems size > 2
- ifTrue:[
- aMenu addList: {
- #-.
- {'distribute vertically' translated. #distributeVertically}.
- {'distribute horizontally' translated. #distributeHorizontally}.
- }.
- ].
!
Item was changed:
----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
+ selectedItems do: [:m | m dismissViaHalo].
-
super dismissViaHalo.
+ !
- selectedItems do: [:m | m dismissViaHalo]!
Item was changed:
----- Method: SelectionMorph>>extent: (in category 'geometry') -----
extent: newExtent
+ "Set the receiver's extent Extend or contract the receiver's selection to encompass morphs within the new extent."
super extent: newExtent.
+ self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])!
- self selectSubmorphsOf: self pasteUpMorph!
Item was changed:
----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: evt
+ "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
selectedItems isEmpty ifTrue:
["Hand just clicked down to draw out a new selection"
^ self extendByHand: evt hand].
+ dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
- 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)] fixTemps].
+ selectedItems _ nil.
+ self removeHalo.
+ self halo ifNotNil: [self halo visible: false].
+ self delete.
- (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
evt wasHandled: true!
Item was changed:
----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') -----
selectSubmorphsOf: aMorph
+ "Given the receiver's current bounds, select submorphs of the indicated pasteup morph that fall entirely within those bounds. If nobody is within the bounds, delete the receiver."
| newItems removals |
+ newItems _ aMorph submorphs select:
- newItems := aMorph submorphs select:
[:m | (bounds containsRect: m fullBounds)
and: [m~~self
and: [(m isKindOf: HaloMorph) not]]].
+ otherSelection ifNil: [^ selectedItems _ newItems].
- otherSelection ifNil: [^ selectedItems := newItems].
+ removals _ newItems intersection: itemsAlreadySelected.
- removals := newItems intersection: itemsAlreadySelected.
otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
+ selectedItems _ (newItems copyWithoutAll: removals).
+ selectedItems ifEmpty: [self delete]
- selectedItems := (newItems copyWithoutAll: removals).
!
Item was changed:
----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') -----
slideToTrash: evt
self delete.
+ "selectedItems do: [:m | m slideToTrash: evt]"!
- selectedItems do: [:m | m slideToTrash: evt]!
Item was changed:
----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
hasContentsInExplorer
+ ^self notEmpty!
- ^self isEmpty not!
Item was changed:
----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
^ self = SimpleButtonMorph
+ ifTrue: ['Button' translatedNoop]
- ifTrue: ['Button']
ifFalse: [^ super defaultNameStemForInstances]!
Item was changed:
----- 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 action selector' translated action: #setActionSelector.
aCustomMenu add: 'change arguments' translated action: #setArguments.
aCustomMenu add: 'change when to act' translated action: #setActWhen.
+ aCustomMenu add: 'set target' translated action: #sightTargets:.
+ target ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]].
- self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
!
Item was changed:
----- 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:
+ [target perform: actionSelector withArguments: arguments].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments]].
actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]!
Item was changed:
----- 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."
+ ^ super 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.
+ Feb 2007: It seems unlikely that Squeak Pages will be used in the OLPC image. Don't use this code. Consider removing all code that supports SqueakPages."
+ "
| bb thatPage um stem ind sqPg |
(actionSelector == #goToPageMorph:fromBookmark:) |
(actionSelector == #goToPageMorph:) ifFalse: [
+ ^ super objectForDataStream: refStrm]. 'normal case'.
- ^ super objectForDataStream: refStrm]. "normal case"
+ target url ifNil: ['Later force target book to get a url.'.
+ bb _ SimpleButtonMorph new. 'write out a dummy'.
- 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.
- (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.
- 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.
- 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'.
- 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
+ "!
- ^ um!
Item was changed:
----- Method: SimpleButtonMorph>>updateVisualState: (in category 'visual properties') -----
updateVisualState: evt
oldColor ifNotNil: [
self color:
((self containsPoint: evt cursorPoint)
+ ifTrue: [oldColor mixed: 0.5 with: Color white]
- ifTrue: [oldColor mixed: 1/2 with: Color white]
ifFalse: [oldColor])]
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ self setProperty: #autoExpand toValue: false.
self
on: #mouseMove
send: #mouseStillDown:onItem:
to: self!
Item was changed:
----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Sketch' translatedNoop!
- ^ 'Sketch'!
Item was changed:
----- Method: SketchMorph>>addToggleItemsToHaloMenu: (in category 'menus') -----
addToggleItemsToHaloMenu: aCustomMenu
+ "Add toggle-items to the halo menu"
+
- "Add toggle-items to the halo menu"
super addToggleItemsToHaloMenu: aCustomMenu.
+ (Smalltalk includesKey: #B3DRenderEngine) ifTrue: [
+ aCustomMenu addUpdating: #useInterpolationString target: self action: #toggleInterpolation.
+ ].
+ !
- Preferences noviceMode
- ifFalse: [""aCustomMenu
- addUpdating: #useInterpolationString
- target: self
- action: #toggleInterpolation]!
Item was changed:
----- Method: SketchMorph>>collapse (in category 'menus') -----
collapse
+ "Replace the receiver with a collapsed rendition of itself."
-
- | priorPosition w collapsedVersion a |
+ | w collapsedVersion a ht tab |
+
+ (w _ self world) ifNil: [^self].
+ collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
- (w := self world) ifNil: [^self].
- collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph.
collapsedVersion setProperty: #uncollapsedMorph toValue: self.
collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
+
+ collapsedVersion setBalloonText: ('A collapsed version of {1}. Click to open it back up.' translated format: {self externalName}).
+
- collapsedVersion setBalloonText: 'A collapsed version of ',self name.
-
self delete.
w addMorphFront: (
+ a _ AlignmentMorph newRow
- a := AlignmentMorph newRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 4;
borderColor: Color white;
+ addMorph: collapsedVersion;
+ yourself).
+ a setNameTo: self externalName.
+ ht := (tab := ActiveWorld findA: SugarNavTab)
+ ifNotNil:
+ [tab height]
+ ifNil:
+ [80].
+ a position: 0@ht.
+
- addMorph: collapsedVersion
- ).
collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+ (self valueOfProperty: #collapsedPosition) ifNotNilDo:
+ [:priorPosition |
+ a position: priorPosition]!
- (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil])
- ifNotNil:
- [a position: priorPosition].
- !
Item was changed:
----- 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 x = 0 or: [newExtent y = 0]) ifTrue: [ ^self ].
- newExtent isZero ifTrue: [ ^self ].
self extent = newExtent ifTrue:[^self].
self scalePoint: newExtent asFloatPoint / (originalForm extent max: 1@1).
self layoutChanged.
!
Item was changed:
----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') -----
flipHorizontal
+ | r |
+ r _ self rotationCenter.
+ self left: self left - (1.0 - (2 * r x) * self width).
+ self form: (self form flipBy: #horizontal centerAt: self form center).
+ self rotationCenter: (1 - r x) @ (r y).!
- self form: (self form flipBy: #horizontal centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>flipVertical (in category 'e-toy support') -----
flipVertical
+ | r |
+ r _ self rotationCenter.
+ self top: self top - (1.0 - (2 * r y) * self height).
+ self form: (self form flipBy: #vertical centerAt: self form center).
+ self rotationCenter: r x @ (1 - r y).!
- self form: (self form flipBy: #vertical centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>initializeWith: (in category 'initialization') -----
initializeWith: aForm
super initialize.
+ originalForm _ aForm.
+ rotationStyle _ #normal. "styles: #normal, #leftRight, #upDown, or #none"
+ scalePoint _ 1.0(a)1.0.
+ framesToDwell _ 1.
+ rotatedForm _ originalForm. "cached rotation of originalForm"
- originalForm := aForm.
- self rotationCenter: 0.5(a)0.5. "relative to the top-left corner of the Form"
- rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none"
- scalePoint := 1.0(a)1.0.
- framesToDwell := 1.
- rotatedForm := originalForm. "cached rotation of originalForm"
self extent: originalForm extent.
!
Item was changed:
----- 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
+ Because my rendering code flips the form (see generateRotatedForm) we 'pre-flip' it here to preserve the same visual appearance.
+ "
- #none -- do not rotate"
+ | wasFlippedX wasFlippedY isFlippedX isFlippedY |
+ wasFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ wasFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ rotationStyle _ aSymbol.
+
+ isFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ isFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ wasFlippedX == isFlippedX
+ ifFalse: [self form: (self form flipBy: #horizontal centerAt: self form center)].
+ wasFlippedY == isFlippedY
+ ifFalse: [self form: (self form flipBy: #vertical centerAt: self form center)].
+
- rotationStyle := aSymbol.
self layoutChanged.
!
Item was changed:
----- Method: Slider>>sliderThickness (in category 'geometry') -----
sliderThickness
+ "^ 7"
+
+ | w |
+ w _ bounds isWide
+ ifTrue: [super height]
+ ifFalse: [super width].
+
+ ^ (w // 32) max: 16.
+ !
- ^ 7!
Item was changed:
----- 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: [FormDictionary at: #Cat]].
+ ^ FormDictionary at: #Cat!
- [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
- ^ nil!
Item was changed:
----- 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.
+ aCustomMenu addUpdating: #usePangoString target: self action: #toggleUsePango.
!
Item was changed:
----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
addOptionalHandlesTo: aHalo box: box
+ "eventually, add more handles for font..."
+
self flag: #deferred.
+ ^ super addOptionalHandlesTo: aHalo box: box
"Eventually...
self addFontHandlesTo: aHalo box: box"!
Item was changed:
----- 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 projectParameterAt: #substitutedFont).
+ (substituteFont notNil and: [self font == substituteFont])
- substituteFont := aProject projectParameters at:
- #substitutedFont ifAbsent: [#none].
- (substituteFont ~~ #none and: [self font == substituteFont])
ifTrue: [ self fitContents ].
^ super fixUponLoad: aProject seg: anImageSegment!
Item was changed:
----- Method: StringMorph>>font: (in category 'printing') -----
font: aFont
"Set the font my text will use. The emphasis remains unchanged."
+ aFont = font ifTrue: [^ self].
+ font _ aFont.
- font := aFont.
^ self font: font emphasis: emphasis!
Item was changed:
----- Method: StringMorphEditor>>initialize (in category 'display') -----
initialize
"Initialize the receiver. Give it a white background"
super initialize.
self backgroundColor: Color white.
+ self textColor: Color red.!
- self color: Color red!
Item was changed:
----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'TrueType banner' translatedNoop
+ categories: #()
+ documentation: 'A short text in a beautiful font. Use the resize handle to change size.' translatedNoop!
- ^ self partName: 'TrueType banner'
- categories: #('Demo')
- documentation: 'A short text in a beautiful font. Use the resize handle to change size.'!
Item was changed:
----- 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' translatedNoop. 'A scrolling data field which will have a different value on every card of the background' translatedNoop}
- 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 changed:
----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') -----
borderedPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t fontName: 'BitstreamVeraSans' pointSize: 24.
t autoFit: false; extent: 250@100.
+ t borderWidth: 1; margins: 4@0; backgroundColor: Color white.
- t borderWidth: 1; margins: 4@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 changed:
----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Text' translatedNoop!
- ^ 'Text'!
Item was changed:
----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') -----
fancyPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t autoFit: false; extent: 150@75.
t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?"
"fancy font, shadow, rounded"
+ t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; fillStyle: Color lightBrown.
- 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 changed:
----- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- 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' translatedNoop. 'A piece of text that will occur on every card of the background' translatedNoop}
- 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' translatedNoop. 'A data field which will have a different value on every card of the background' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you wish' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish')
forFlapNamed: 'Stack Tools'.
+ cl registerQuad: {#TextMorph . #fancyPrototype. 'Fancy Text' translatedNoop. 'A text field with a rounded shadowed border, with a fancy font.' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
forFlapNamed: 'Supplies'.]!
Item was changed:
----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+ (self backgroundColor isNil or: [self backgroundColor asColor isTranslucent])
- (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 changed:
----- Method: TextMorph>>backgroundColor (in category 'accessing') -----
backgroundColor
+ ^ self fillStyle.
+ !
- ^ backgroundColor!
Item was changed:
----- Method: TextMorph>>backgroundColor: (in category 'accessing') -----
backgroundColor: newColor
+ self fillStyle: newColor.
+ !
- backgroundColor := newColor.
- self changed!
Item was changed:
----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
beAllFont: aFont
+ textStyle _ TextStyle fontArray: (Array with: aFont).
+ text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)].
- textStyle := TextStyle fontArray: (Array with: aFont).
self releaseCachedState; changed!
Item was changed:
----- Method: TextMorph>>defaultLineHeight (in category 'geometry') -----
defaultLineHeight
+ ^ ( textStyle fontAt: textStyle defaultFontIndex) pointSize!
- ^ textStyle lineGrid!
Item was changed:
----- Method: TextMorph>>fillStyle: (in category 'visual properties') -----
fillStyle: aFillStyle
"Set the current fillStyle of the receiver."
+ fillStyle _ aFillStyle.
+ backgroundColor _ aFillStyle asColor. "We should get rid of this variable."
- self setProperty: #fillStyle toValue: aFillStyle.
- "Workaround for Morphs not yet converted"
- backgroundColor := aFillStyle asColor.
self changed.!
Item was changed:
----- 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 wid |
- | newExtent para cBounds lastOfLines heightOfLast |
self isAutoFit
ifTrue:
+ [wid _ (text notNil and: [text size > 2]) ifTrue: [5] ifFalse: [40].
+ newExtent := (self paragraph extent max: wid @ ( self defaultLineHeight)) + (0 @ 2).
- [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 changed:
----- Method: TextMorph>>insertCharacters: (in category 'scripting access') -----
+ insertCharacters: aString
- insertCharacters: aSource
"Insert the characters from the given source at my current cursor position"
+ | aLoc aText attributes |
- | aLoc |
aLoc := self cursor max: 1.
+ aText := aLoc > text size
+ ifTrue: [aString asText]
+ ifFalse: [
+ attributes := (text attributesAt: aLoc)
+ select: [:attr | attr mayBeExtended].
+ Text string: aString attributes: attributes].
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aText displaying: true.
- paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
self updateFromParagraph !
Item was changed:
----- 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].
- [paragraph := nil].
container ifNotNil:
+ [container isMorph ifTrue: [container releaseCachedState]]!
- [container releaseCachedState]!
Item was changed:
----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') -----
setAllButFirstCharacter: source
"Set all but the first char of the receiver to the source"
+ | chars |
+ (chars _ self getCharacters) isEmpty
- | aChar chars |
- aChar := source asCharacter.
- (chars := self getCharacters) isEmpty
ifTrue: [self newContents: 'ยท' , source asString]
+ ifFalse: [self newContents: (String
- ifFalse: [chars first = aChar
- ifFalse: [""
- self
- newContents: (String
streamContents: [:aStream |
aStream nextPut: chars first.
+ aStream nextPutAll: source])]!
- aStream nextPutAll: source])]] !
Item was changed:
----- Method: TextMorph>>textColor: (in category 'accessing') -----
textColor: aColor
+ self editor selectFrom: 1 to: 0.
+ self selectionColor: aColor.
- color = aColor ifTrue: [^ self].
- color := aColor.
- self changed.
!
Item was changed:
----- Method: TheWorldMenu>>remoteMenu (in category 'construction') -----
remoteMenu
"Build the Telemorphic menu for the world."
+ ^self fillIn: (self menu: 'Telemorphic' translatedNoop) from: {
+ { 'local host address' translatedNoop. { #myWorld . #reportLocalAddress } }.
+ { 'connect remote user' translatedNoop. { #myWorld . #connectRemoteUser } }.
+ { 'disconnect remote user' translatedNoop. { #myWorld . #disconnectRemoteUser } }.
+ { 'disconnect all remote users' translatedNoop. { #myWorld . #disconnectAllRemoteUsers } }.
- ^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 changed:
----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') -----
windowsMenu
"Build the windows menu for the world."
+ ^ self fillIn: (self menu: 'windows' translatedNoop) from: {
+ { 'find window' translatedNoop. { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' translatedNoop}.
- ^ 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...' translatedNoop. { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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...' translatedNoop. { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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.' translatedNoop}.
- tile: new windows positioned so that they do not overlap others, if possible.'}.
nil.
+ { 'collapse all windows' translatedNoop. { #myWorld . #collapseAllWindows }. 'Reduce all open windows to collapsed forms that only show titles.' translatedNoop}.
+ { 'collapse all objects' translatedNoop. { #myWorld . #collapseAllWindowsAndNonWindows }. 'Reduce all open windows and all other objects on the desktop to labeled tabs' translatedNoop}.
+ { 'expand all' translatedNoop. { #myWorld . #expandAllCollapsedObjects }. 'Expand all collapsed windows and other collapsed objects back to their expanded forms.' translatedNoop}.
+
+ { 'close top window (w)' translatedNoop. { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.' translatedNoop}.
+ { 'send top window to back (\)' translatedNoop. { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.' translatedNoop}.
+ { 'move windows onscreen' translatedNoop. { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen' translatedNoop}.
- { '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' translatedNoop. { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.' translatedNoop}.
+ { 'delete non-windows' translatedNoop. { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.' translatedNoop}.
+ { 'delete both of the above' translatedNoop. { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' translatedNoop}.
- { '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 changed:
----- 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."
+ | args |
(target notNil and: [actionSelector notNil])
ifTrue:
+ [args := actionSelector numArgs > arguments size
+ ifTrue:
+ [arguments copyWith: ActiveEvent]
+ ifFalse:
+ [arguments].
+ Cursor normal
+ showWhile: [target perform: actionSelector withArguments: args].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments].
target isMorph ifTrue: [target changed]]!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| now dt |
- self state: #pressed.
actWhen == #buttonDown
+ ifTrue: [self doButtonAction].
+ actWhen == #buttonUp
+ ifTrue: [self state: #pressed].
+ actWhen == #whilePressed
+ ifTrue:
+ [self state: #pressed.
+ now _ Time millisecondClockValue.
- 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"
+ "NOTE: this delay is temporary disabled because it makes event reaction delay,
+ e.g. the action is not stopped even if you release the button... - Takashi"
+ [dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
+ self mouseStillDown: evt].
+ super mouseDown: evt!
- dt := Time millisecondClockValue - now max: 0. "Time it took to do"
- dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
- self mouseStillDown: evt.!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ (#(#buttonUp #whilePressed ) includes: actWhen)
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #pressed]
+ ifFalse: [self state: #off]].
+ super mouseMove: evt!
- 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 changed:
----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
- mouseUp: evt
"Allow on:send:to: to set the response to events other than actWhen"
+ actWhen == #buttonDown
+ ifTrue: [super mouseUp: evt].
+ actWhen == #buttonUp
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #on.
+ self doButtonAction: evt.
+ super mouseUp: evt]
+ ifFalse: [self state: #off.
+ target
+ ifNotNil: ["Allow owner to keep it selected for radio
+ buttons"
+ target mouseUpBalk: evt]]].
+ actWhen == #whilePressed
+ ifTrue: [self state: #off.
+ super mouseUp: evt]!
- 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 changed:
----- 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: [1]
- ifTrue: [ 2]
ifFalse: [1]!
Item was changed:
----- Method: UpdatingStringMorph>>decimalPlaces (in category 'accessing') -----
decimalPlaces
"Answer the number of decimal places to show."
| places |
+ (places _ decimalPlaces) ifNotNil: [^ places].
+ self decimalPlaces: (places _ Utilities decimalPlacesForFloatPrecision: self floatPrecision).
- (places := self valueOfProperty: #decimalPlaces) ifNotNil: [^ places].
- self setProperty: #decimalPlaces toValue: (places := Utilities decimalPlacesForFloatPrecision: self floatPrecision).
^ places!
Item was changed:
----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') -----
fitContents
+ | newExtent |
+ newExtent := self measureContents.
+ newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.
- | 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 changed:
----- Method: UpdatingStringMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver to have default values in its instance variables."
- "Initialie the receiver to have default values in its instance
- variables "
super initialize.
""
+ format _ #default.
- format := #default.
"formats: #string, #default"
+ target _ getSelector _ putSelector _ nil.
+ floatPrecision _ 1.
+ growable _ true.
+ stepTime _ nil.
+ autoAcceptOnFocusLoss _ true.
+ minimumWidth _ 8.
+ maximumWidth _ 366!
- target := getSelector := putSelector := nil.
- floatPrecision := 1.
- growable := true.
- stepTime := 50.
- autoAcceptOnFocusLoss := true.
- minimumWidth := 8.
- maximumWidth := 300!
Item was changed:
----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') -----
readFromTarget
"Update my readout from my target"
+ | v ret places |
- | v ret |
(target isNil or: [getSelector isNil]) ifTrue: [^contents].
+ ret _ self checkTarget.
- ret := self checkTarget.
ret ifFalse: [^ '0'].
+ ((target isMorph) or:[target isPlayerLike]) ifTrue:[
+ places _ target decimalPlacesForGetter: getSelector.
+ (places ~= nil and: [ places ~= decimalPlaces ]) ifTrue: [ self decimalPlaces: places ]].
v := target perform: getSelector. "scriptPerformer"
(v isKindOf: Text) ifTrue: [v := v asString].
^self acceptValueFromTarget: v!
Item was changed:
----- 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 := MenuMorph new.
aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
+ 0 to: 10 do:
- 0 to: 5 do:
[:places |
aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
aMenu popUpInWorld!
Item was changed:
----- Method: UpdatingStringMorph>>stepTime (in category 'testing') -----
stepTime
+ ^ stepTime ifNil: [200]
- ^ stepTime ifNil: [50]
!
Item was changed:
----- 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.
+ decimalPlaces _ decimalPlaces veryDeepCopyWith: 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.
!
1
0
Tim Felgentreff uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-tfel.1244.mcz
==================== Summary ====================
Name: Morphic-tfel.1244
Author: tfel
Time: 9 August 2016, 4:45:20.67266 pm
UUID: c49419cd-9954-a041-b0e4-242c36832114
Ancestors: Morphic-tfel.1243
fix references to undefined symbols by removing dead code paths
=============== Diff against Morphic-mt.1240 ===============
Item was changed:
----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
supplementaryPartsDescriptions
"Extra items for parts bins"
^ {DescriptionForPartsBin
+ formalName: 'Circle' translatedNoop
+ categoryList: {'Graphics' translatedNoop}
+ documentation: 'A circular shape' translatedNoop
- formalName: 'Circle1'
- categoryList: #('Graphics')
- documentation: 'A circular shape'
globalReceiverSymbol: #CircleMorph
nativitySelector: #newStandAlone.
+ DescriptionForPartsBin
+ formalName: 'Pin' translatedNoop
+ categoryList: {'Connectors' translatedNoop}
+ documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop
- "DescriptionForPartsBin
- formalName: 'Pin'
- categoryList: #('Connectors')
- documentation: 'An attachment point for Connectors that you can embed in another Morph.'
globalReceiverSymbol: #NCPinMorph
+ nativitySelector: #newPin.
- nativitySelector: #newPin."
}!
Item was changed:
SketchMorph subclass: #ColorPickerMorph
+ instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency noChart'
+ classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransparentBox TransText'
- 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 changed:
----- 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 @ 31. "<<<< the form was changed a bit??"
- 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 changed:
----- 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 insetBy: 2) fillColor: feedbackColor.
- originalForm fill: FeedbackBox fillColor: feedbackColor.
self form: originalForm.
+ selectedColor _ aColor.
- selectedColor := aColor.
updateContinuously ifTrue: [self updateTargetColor].
self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).!
Item was changed:
----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Ellipse' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'An elliptical or circular shape' translatedNoop!
- ^ self partName: 'Ellipse'
- categories: #('Graphics' 'Basic')
- documentation: 'An elliptical or circular shape'!
Item was changed:
----- Method: HaloMorph>>addDupHandle: (in category 'handles') -----
addDupHandle: haloSpec
"Add the halo that offers duplication, or, when shift is down, make-sibling"
+ | aSelector |
+ aSelector := innerTarget couldMakeSibling
+ ifTrue:
+ [#doDupOrMakeSibling:with:]
+ ifFalse:
+ [#doDup:with:].
- self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self
+ self addHandle: haloSpec on: #mouseDown send: aSelector to: self
+
!
Item was changed:
----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') -----
addHandlesForWorldHalos
"Add handles for world halos, like the man said"
| box w |
+ w _ self world ifNil:[target world].
- w := self world ifNil:[target world].
self removeAllMorphs. "remove old handles, if any"
self bounds: target bounds.
+ box _ w bounds insetBy: self handleSize // 2.
- box := w bounds insetBy: 9.
target addWorldHandlesTo: self box: box.
Preferences uniqueNamesInHalos ifTrue:
[innerTarget assureExternalName].
self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
+ growingOrRotating _ false.
- growingOrRotating := false.
self layoutChanged.
self changed.
!
Item was changed:
----- Method: HaloMorph>>addViewingHandle: (in category 'handles') -----
addViewingHandle: haloSpec
+ "If appropriate, add a special Viewing halo handle to the receiver. On 26 Sept 07, we decided to eliminate this item from the UI, so the code of is method is now commented out...
- "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 changed:
----- Method: HaloMorph>>basicBox (in category 'private') -----
basicBox
| aBox minSide anExtent w |
+ minSide _ 4 * self handleSize.
+ anExtent _ ((self width + self handleSize + 8) max: minSide) @
- 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].
- aBox := Rectangle center: self center extent: anExtent.
- w := self world ifNil:[target outermostWorldMorph].
^ w
ifNil:
[aBox]
ifNotNil:
+ [aBox intersect: (w viewBox insetBy: self handleSize // 2)]
- [aBox intersect: (w viewBox insetBy: 8@8)]
!
Item was changed:
----- Method: HaloMorph>>doDirection:with: (in category 'private') -----
doDirection: anEvent with: directionHandle
+ "The mouse went down on the forward-direction halo handle; respond appropriately."
+
anEvent hand obtainHalo: self.
+ anEvent shiftPressed
+ ifTrue:
+ [directionArrowAnchor _ (target point: target referencePosition in: self world) rounded.
+ self positionDirectionShaft: directionHandle.
+ self removeAllHandlesBut: directionHandle.
+ directionHandle setProperty: #trackDirectionArrow toValue: true]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: directionHandle]!
- self removeAllHandlesBut: directionHandle!
Item was changed:
----- Method: HaloMorph>>handleSize (in category 'private') -----
handleSize
^ Preferences biggerHandles
+ ifTrue: [30]
- ifTrue: [20]
ifFalse: [16]!
Item was changed:
----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') -----
prepareToTrackCenterOfRotation: evt with: rotationHandle
+ "The mouse went down on the center of rotation."
+
evt hand obtainHalo: self.
+ evt shiftPressed
+ ifTrue:
+ [self removeAllHandlesBut: rotationHandle.
+ rotationHandle setProperty: #trackCenterOfRotation toValue: true.
+ evt hand showTemporaryCursor: Cursor blank]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: rotationHandle]!
- evt shiftPressed ifTrue:[
- self removeAllHandlesBut: rotationHandle.
- ] ifFalse:[
- rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
- self startDrag: evt with: rotationHandle
- ].
- evt hand showTemporaryCursor: Cursor blank!
Item was changed:
----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') -----
setCenterOfRotation: evt with: rotationHandle
| localPt |
evt hand obtainHalo: self.
evt hand showTemporaryCursor: nil.
+ (rotationHandle hasProperty: #trackCenterOfRotation) ifTrue:
+ [localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
+ innerTarget setRotationCenterFrom: localPt].
+
+ rotationHandle removeProperty: #trackCenterOfRotation.
+ self endInteraction!
- (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
- localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
- innerTarget setRotationCenterFrom: localPt.
- ].
- rotationHandle removeProperty: #dragByCenterOfRotation.
- self endInteraction
- !
Item was changed:
----- 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"
+ (directionHandle hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ target setDirectionFrom: directionHandle center.
+ directionHandle removeProperty: #trackDirectionArrow.
+ self endInteraction]!
- anEvent hand obtainHalo: self.
- target setDirectionFrom: directionHandle center.
- self endInteraction!
Item was changed:
----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') -----
trackCenterOfRotation: anEvent with: rotationHandle
(rotationHandle hasProperty: #dragByCenterOfRotation)
ifTrue:[^self doDrag: anEvent with: rotationHandle].
+ (rotationHandle hasProperty: #trackCenterOfRotation)
+ ifTrue:
+ [anEvent hand obtainHalo: self.
+ rotationHandle center: anEvent cursorPoint]!
- anEvent hand obtainHalo: self.
- rotationHandle center: anEvent cursorPoint.!
Item was changed:
----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') -----
trackDirectionArrow: anEvent with: shaft
+ (shaft hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
+ self layoutChanged]!
- anEvent hand obtainHalo: self.
- shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
- self layoutChanged!
Item was changed:
----- Method: HandleMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self extent: 16 @ 16.
- self extent: 8 @ 8.
!
Item was changed:
----- Method: IconicButton>>stationarySetup (in category 'initialization') -----
stationarySetup
+ "Set up event handlers for mouse actions. Should be spelled stationery..."
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.
+
+ self on: #click send: #launchPartFromClick to: self!
- self on: #mouseUp send: #borderThick to: self.!
Item was changed:
----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Image' translatedNoop
+ categories: #()
+ documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.' translatedNoop!
- ^ 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 changed:
----- 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' translatedNoop. 'A non-editable picture of something' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Joystick' translatedNoop
+ categories: {'Basic' translatedNoop}
+ documentation: 'A joystick-like control' translatedNoop!
- ^ self partName: 'Joystick'
- categories: #('Useful')
- documentation: 'A joystick-like control'!
Item was changed:
----- 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' translatedNoop. 'A joystick-like control' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Scripting'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ "Answer a description for the parts bin."
+
+ ^ self partName: 'Line' translatedNoop
+ categories: {'Graphics' translatedNoop}
+ documentation: 'A straight line. Shift-click to get handles and move the ends.' translatedNoop!
- ^ self partName: 'Line'
- categories: #('Graphics' 'Basic')
- documentation: 'A straight line. Shift-click to get handles and move the ends.'!
Item was changed:
----- 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.
- ActiveWorld addMorph: self centeredNear: aPoint.
self world displayWorld. "show myself"
+ aBlock value]
+ ensure: [self delete]!
- aBlock value.
- self delete!
Item was changed:
----- Method: MenuIcons class>>iconForMenuItem: (in category 'menu decoration') -----
iconForMenuItem: anItem
+ "Answer the icon (or nil) corresponding to a given menu item."
- "Answer the icon (or nil) corresponding to the (translated) string."
+ | aKey |
+ aKey _ (anItem selector == #undoOrRedoCommand)
+ ifTrue:
+ ['undo (z)' translated] "Actual wording changes dynamically"
+ ifFalse:
+ [anItem contents asString].
+ ^ TranslatedIcons at: aKey asLowercase ifAbsent: [nil]!
- ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]!
Item was changed:
----- Method: MenuMorph>>delete (in category 'initialization') -----
delete
+ "Delete the receiver."
+
+ activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]].
+ self isFlexed ifTrue: [^ owner delete].
+ ^ super delete!
- activeSubMenu ifNotNil:[activeSubMenu delete].
- ^super delete!
Item was changed:
----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') -----
serviceLoadMorphFromFile
"Answer a service for loading a .morph file"
^ SimpleServiceEntry
provider: self
+ label: 'load as morph' translatedNoop
- label: 'load as morph'
selector: #fromFileName:
+ description: 'load as morph' translatedNoop
+ buttonLabel: 'load' translatedNoop!
- description: 'load as morph'
- buttonLabel: 'load'!
Item was changed:
----- 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 w |
+ menu _ MenuMorph new defaultTarget: self.
+ w _ self world.
+ self potentialEmbeddingTargets reverseDo: [:m |
+ menu add: (m == w ifTrue: ['desktop' translated] ifFalse: [m knownName ifNil:[m class name asString]]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}.
+ m == self topRendererOrSelf owner ifTrue:
+ [menu lastItem color: Color red]].
+ aMenu ifNotNil:
+ [menu submorphCount > 0
+ ifTrue:[aMenu add:'embed into' translated subMenu: 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 changed:
----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') -----
addFlexShell
"Wrap a rotating and scaling shell around this morph."
+ | oldHalo flexMorph myWorld anIndex morphOwner |
- | oldHalo flexMorph myWorld anIndex |
myWorld := self world.
+ oldHalo:= self halo.
+ self owner ifNotNil:[ morphOwner := self owner]
+ ifNil:[morphOwner := self currentWorld].
+
+ anIndex := morphOwner submorphIndexOf: self.
+ morphOwner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self)
- 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 changed:
----- Method: Morph>>addHaloActionsTo: (in category 'menus') -----
addHaloActionsTo: aMenu
"Add items to aMenu representing actions requestable via halo"
| subMenu |
+ subMenu _ MenuMorph new defaultTarget: self.
- 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 add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles.
subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.
+ subMenu add: 'tile representing this object' translated target: self action: #tearOffTile.
- 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 changed:
----- 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 notNil and: [aNumber <= submorphs size])
- (aNumber <= submorphs size)
ifTrue:
[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
ifFalse:
+ [self addMorphBack: aMorph]!
- [self addMorphBack: aMorph]
- !
Item was changed:
----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') -----
chooseNewGraphicCoexisting: aBoolean
"Allow the user to choose a different form for her form-based morph"
+
| replacee aGraphicalMenu |
+ self isInWorld ifFalse: "menu must have persisted for a not-in-world object."
+ [aGraphicalMenu := ActiveWorld submorphThat:
+ [:m | (m isKindOf: GraphicalMenu) and: [m target == self]]
+ ifNone:
+ [^ self].
+ ^ aGraphicalMenu show; flashBounds].
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 changed:
----- Method: Morph>>couldMakeSibling (in category 'testing') -----
couldMakeSibling
"Answer whether it is appropriate to ask the receiver to make a sibling"
+ ^ self isWorldMorph not!
- ^ true!
Item was changed:
----- Method: Morph>>goBehind (in category 'submorphs-add/remove') -----
goBehind
+ "Move the receiver to bottom z-order."
+ | topRend |
+ topRend := self topRendererOrSelf.
+ topRend owner ifNotNilDo:
+ [:own | own addMorphNearBack: topRend]
- owner addMorphNearBack: self.
!
Item was changed:
----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') -----
invokeMetaMenu: evt
+ "Put up the 'meta' menu, invoked via control-click, unless eToyFriendly is true."
+
| menu |
+ Preferences eToyFriendly ifTrue: [^ self].
+
+ menu _ self buildMetaMenu: evt.
- menu := self buildMetaMenu: evt.
menu addTitle: self externalName.
+ menu popUpEvent: evt in: self world!
- self world ifNotNil: [
- menu popUpEvent: evt in: self world
- ]!
Item was changed:
----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') -----
obtrudesBeyondContainer
"Answer whether the receiver obtrudes beyond the bounds of its container"
+ | top formerOwner |
- | top |
top := self topRendererOrSelf.
+ top owner ifNil: [^ false].
+ ^ top owner isHandMorph
+ ifTrue:
+ [((formerOwner := top formerOwner) notNil and: [formerOwner isInWorld])
+ ifFalse:
+ [false]
+ ifTrue:
+ [(formerOwner boundsInWorld containsRect: top boundsInWorld) not]]
+ ifFalse:
+ [(top owner bounds containsRect: top bounds) not]!
- (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
- ^(top owner bounds containsRect: top bounds) not!
Item was changed:
----- Method: Morph>>on:send:to: (in category 'event handling') -----
on: eventName send: selector to: recipient
+ "When the given event occurs, send the given selector to the given recipient. If the given selector is nil, rescind any earlier handling for the given event type,"
+
+ self eventHandler ifNil:
+ [selector ifNil: [^ self]. "Don't pointlessly create an event handler!!"
+ self eventHandler: EventHandler new].
- self eventHandler ifNil: [self eventHandler: EventHandler new].
self eventHandler on: eventName send: selector to: recipient!
Item was changed:
----- Method: Morph>>openViewerForArgument (in category 'player viewer') -----
openViewerForArgument
+ Cursor wait
+ showWhile: [self presenter viewMorph: self]!
- "Open up a viewer for a player associated with the morph in question. "
- self presenter viewMorph: self!
Item was changed:
----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') -----
overlapsShadowForm: itsShadow bounds: itsBounds
"Answer true if itsShadow and my shadow overlap at all"
+ | overlapExtent overlap myRect myShadow goalRect goalShadow bb |
+ overlap _ self fullBounds intersect: itsBounds.
+ overlapExtent _ overlap extent.
- | andForm overlapExtent |
- overlapExtent := (itsBounds intersect: self fullBounds) extent.
overlapExtent > (0 @ 0)
ifFalse: [^ false].
+ myRect := overlap translateBy: 0 @ 0 - self topLeft.
+ myShadow := (self imageForm contentsOfArea: myRect) stencil.
+ goalRect := overlap translateBy: 0 @ 0 - itsBounds topLeft.
+ goalShadow := (itsShadow contentsOfArea: goalRect) stencil.
+
+ "compute a pixel-by-pixel AND of the two stencils. Result will be black
+ (pixel value = 1) where black parts of the stencils overlap"
+ bb := BitBlt toForm: myShadow.
+ bb
+ copyForm: goalShadow
+ to: 0 @ 0
+ rule: Form and.
+
+ ^(bb destForm tallyPixelValues second) > 0 !
- 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 changed:
----- Method: Morph>>roundUpStrays (in category 'miscellaneous') -----
roundUpStrays
+ "Bring submorphs of playfieldlike structures in the receiver's interior back within view."
+
+ self submorphsDo:
+ [:m | m isPlayfieldLike ifTrue: [m roundUpStrays]]!
- self submorphs
- do: [:each | each roundUpStrays]!
Item was changed:
----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
slideBackToFormerSituation: evt
+ "A drop of the receiver having been rejected, slide it back to where it came from, if possible."
+
| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
formerOwner := self formerOwner.
formerPosition := self formerPosition.
+ (aWorld := evt hand world) ifNil: [^ self delete]. "Likely a moribund hand from an EventRecorder playback."
+
- 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.
+ "The OLPC Virtual Screen wouldn't notice the last update here."
+ Display forceToScreen: (endPoint extent: slideForm extent).
formerOwner addMorph: self.
self position: formerPosition.
self justDroppedInto: formerOwner event: evt!
Item was changed:
----- Method: Morph>>useGradientFill (in category 'visual properties') -----
useGradientFill
"Make receiver use a solid fill style (e.g., a simple color)"
+
+ | fill color1 color2 fil |
+ ((fil := self fillStyle) notNil and: [fil isSymbol not] and: [fil isGradientFill]) ifTrue:[^self]. "Already done"
+ color1 _ self color asColor.
+ color2 _ color1 negated.
+ fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
- | 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 changed:
----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') -----
wantsHaloFromClick
+
+ ^ self valueOfProperty: #wantsHaloFromClick ifAbsent: [^true].!
- ^ true!
Item was changed:
----- Method: MorphicProject>>updateLocaleDependents (in category 'language') -----
updateLocaleDependents
"Set the project's natural language as indicated"
ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
viewerOrScriptor localeChanged].
Flaps disableGlobalFlaps: false.
+ (Preferences eToyFriendly or: [Smalltalk globals at: #SugarNavigatorBar ifPresent: [:c | c showSugarNavigator] ifAbsent: [false]])
- Preferences eToyFriendly
ifTrue: [
Flaps addAndEnableEToyFlaps.
ActiveWorld addGlobalFlaps]
ifFalse: [Flaps enableGlobalFlaps].
(Project current isFlapIDEnabled: 'Navigator' translated)
ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].
ScrapBook default emptyScrapBook.
MenuIcons initializeTranslations.
super updateLocaleDependents.
"self setFlaps.
self setPaletteFor: aLanguageSymbol."
!
Item was changed:
----- 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 := 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 wantsMouseOverHalos: false.
proto beSticky.
^ proto!
Item was changed:
----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
"Answer a basis for names of default instances of the receiver"
+ ^ 'playfield' translatedNoop!
- ^ 'playfield'!
Item was changed:
----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') -----
addPenMenuItems: menu hand: aHandMorph
"Add a pen-trails-within submenu to the given menu"
+ menu add: 'pen trails...' translated target: self selector: #putUpPenTrailsSubmenu.
+ menu balloonTextForLastItem: 'its governing pen trails drawn within' translated!
- menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu!
Item was changed:
----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') -----
addPenTrailsMenuItemsTo: aMenu
"Add items relating to pen trails to aMenu"
| oldTarget |
+ oldTarget _ aMenu defaultTarget.
- 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 addLine.
+ aMenu addUpdating: #batchPenTrailsString action: #toggleBatchPenTrails.
+ aMenu balloonTextForLastItem: 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.' translated.
+
aMenu defaultTarget: oldTarget!
Item was changed:
----- Method: PasteUpMorph>>addWorldToggleItemsToHaloMenu: (in category 'menu & halo') -----
addWorldToggleItemsToHaloMenu: aMenu
+ "Add toggle items for the world to the halo menu .... July 2009: no longer in world halo menu"
- "Add toggle items for the world to the halo menu"
+ "aMenu addUpdating: #showTabsString
+ target: CurrentProjectRefactoring
+ action: #currentToggleFlapsSuppressed "!
- #(
- (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 changed:
----- 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.
+ self changed "redraw"
- self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
!
Item was changed:
----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') -----
chooseClickTarget
Cursor crossHair showWhile:
[Sensor waitButton].
Cursor down showWhile:
[Sensor anyButtonPressed].
+ ^ (self morphsAt: Sensor cursorPoint) first topRendererOrSelf!
- ^ (self morphsAt: Sensor cursorPoint) first!
Item was changed:
----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') -----
correspondingFlapTab
+ "If there is a flap tab whose referent is me, return it, else return nil. Will also work for flaps on the edge of embedded subareas such as within scripting-areas, but more slowly."
+
- "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]].
+
+ "Catch guys in embedded worldlets"
+ ActiveWorld allMorphs do:
+ [:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]].
+
^ nil!
Item was changed:
----- 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' translatedNoop]!
- ['world']!
Item was changed:
----- 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@0) anyShapeFill reverse.
+ screenForm _ Form fromDisplay: (topLeft extent: outline extent).
- outline := poly shadowForm.
- topLeft := outline offset.
- exterior := (outline offset: 0@0) anyShapeFill reverse.
- screenForm := Form fromDisplay: (topLeft extent: outline extent).
screenForm eraseShape: exterior.
+ innerForm _ screenForm trimBordersOfColor: Color transparent.
+ ActiveHand showTemporaryCursor: nil.
- innerForm := screenForm trimBordersOfColor: Color transparent.
innerForm isAllWhite ifFalse:
[hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was changed:
----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
flapTab
+ "Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'"
+
| ww |
self isFlap ifFalse:[^nil].
+ ww _ self presenter associatedMorph ifNil: [ActiveWorld].
+ ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]!
- ww := self world ifNil: [World].
- ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]!
Item was changed:
----- 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>'])
+ , 'grid visible when gridding' translated!
- , 'show grid when gridding' translated!
Item was changed:
----- Method: PasteUpMorph>>installFlaps (in category 'world state') -----
installFlaps
"Get flaps installed within the bounds of the receiver"
+ | localFlapTabs |
Project current assureFlapIntegrity.
self addGlobalFlaps.
+ localFlapTabs := self localFlapTabs.
+ localFlapTabs do: [:each | each visible: false].
+
+ Preferences eToyFriendly ifTrue: [
+ ProgressInitiationException display: 'Building Viewers...' translated
+ during: [:bar |
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld.
+ bar value: i / self localFlapTabs size]].
+ ] ifFalse: [
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld]].
+
- self localFlapTabs do:
- [:aFlapTab | aFlapTab adaptToWorld].
self assureFlapTabsFitOnScreen.
self bringTopmostsToFront!
Item was changed:
----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') -----
presentCardAndStackMenu
"Put up a menu holding card/stack-related options."
| aMenu |
+ aMenu _ MenuMorph new defaultTarget: self.
- aMenu := MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
+ aMenu addTitle: 'card and stack' translated.
+ aMenu add: 'add new card' translated action: #insertCard.
+ aMenu add: 'delete this card' translated action: #deleteCard.
+ aMenu add: 'go to next card' translated action: #goToNextCardInStack.
+ aMenu add: 'go to previous card' translated action: #goToPreviousCardInStack.
- 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' translated action: #showForegroundObjects.
+ aMenu add: 'show background objects' translated action: #showBackgroundObjects.
+ aMenu add: 'show designations' translated action: #showDesignationsOfObjects.
+ aMenu add: 'explain designations' translated action: #explainDesignations.
- 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 changed:
----- Method: PasteUpMorph>>referencePool (in category 'objects from disk') -----
referencePool
^ self
valueOfProperty: #References
+ ifAbsentPut: [WeakValueDictionary new]
+ !
- ifAbsentPut: [OrderedCollection new]
-
- !
Item was changed:
----- 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 changed:
----- 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]!
- aPlayer startRunning; step; stopRunning].
-
- self allScriptors do:
- [:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
- !
Item was changed:
----- 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 stopSound.
+ aPlayer stopRunning].
- aPlayer stopRunning].
- self allScriptors do:
- [:aScript | aScript pauseIfTicking].
self world updateStatusForAllScriptEditors!
Item was changed:
----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') -----
triggerClosingScripts
"If the receiver has any scripts set to run on closing, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllClosingScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllClosingScripts]!
Item was changed:
----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') -----
triggerOpeningScripts
"If the receiver has any scripts set to run on opening, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllOpeningScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllOpeningScripts]!
Item was changed:
----- 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:
+ [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]!
- [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 changed:
----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
setTextColor: aColor
"Set the color of my text to the given color"
+ textMorph textColor: aColor!
- textMorph color: aColor!
Item was changed:
----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Polygon' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ 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.' translatedNoop!
- ^ 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 changed:
----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu 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."
+
- addCustomMenuItems: aMenu hand: aHandMorph
- | |
super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles.
+ vertices size > 2 ifTrue:
+ [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed].
+
+ aMenu addUpdating: #smoothPhrase target: self action: #toggleSmoothing.
+ aMenu addLine.
+ aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
+
+ self isOpen ifTrue:
+ [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]].!
- 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 changed:
----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
+
+ ^ Color black
+
+ "Until September 2007, this had long been...
^ Color
r: 0.0
g: 0.419
+ b: 0.935"!
- b: 0.935!
Item was changed:
----- Method: PolygonMorph>>fillStyle (in category 'visual properties') -----
fillStyle
+ "Answer the receiver's fillStyle. For an *open* polygon, we return the borderColor, provided it's a true color rather than something strange like the symbol #raised."
+ | aColor |
self isOpen
+ ifTrue:
+ [(aColor := self borderColor) isColor ifTrue: [^ aColor]]. "easy access to line color from halo -- di's old note"
+
+ ^ super fillStyle!
- ifTrue: [^ self borderColor "easy access to line color from halo"]
- ifFalse: [^ super fillStyle]!
Item was changed:
----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') -----
handlesShowingPhrase
+ "Answer a phrase characterizing whether handles are showing or not."
+
+ ^ (self showingHandles ifTrue: ['<yes>'] ifFalse: ['<no>']), ('show handles' translated)!
- ^ (self showingHandles
- ifTrue: ['hide handles']
- ifFalse: ['show handles']) translated!
Item was changed:
----- Method: PolygonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
+ "Handle a mouse-down event."
+ ^ (evt shiftPressed and: [(self hasProperty: #activateOnShift) not])
- ^ 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 changed:
----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') -----
openOrClosePhrase
+ "Answer a string indicating whether the receiver is open or closed."
+
+ ^ (closed ifTrue: ['<yes>'] ifFalse: ['<no>']), 'closed' translated!
- | 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 changed:
----- Method: PolygonMorph>>stepTime (in category 'testing') -----
stepTime
+ "Answer the desired time between steps in milliseconds."
+ ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [100]
+
+ "NB: in all currently known cases, polygons are not actually wrapped in TransformationMorphs, so the #topRendererOrSelf call above is probably redundant, but is retained for safety."!
- ^ 100!
Item was changed:
----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') -----
+ verticesAt: anInteger put: aPoint
+
+ self vertices at: anInteger put: aPoint asFloatPoint.
- verticesAt: ix put: newPoint
- vertices at: ix put: newPoint.
self computeBounds!
Item was changed:
----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') -----
allCurrentlyTickingScriptInstantiations
+ "Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking."
+
+ ^ Array streamContents:
+ [:aStream |
+ self allExtantPlayers do:
+ [:aPlayer | aPlayer instantiatedUserScriptsDo:
+ [:aScriptInstantiation |
+ aScriptInstantiation status == #ticking ifTrue:
+ [aStream nextPut: aScriptInstantiation]]]]!
- ^#()!
Item was changed:
----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') -----
+ browseAllScriptsTextually
+ "Open a method-list browser on all the scripts in the project"
+
+ | aList aMethodList |
+ self flushPlayerListCache. "Just to be certain we get everything"
+
+ (aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players' translated].
+ aMethodList _ OrderedCollection new.
+ aList do:
+ [:aPair | aPair first addMethodReferencesTo: aMethodList].
+ aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!' translated].
+
+ SystemNavigation new
+ browseMessageList: aMethodList
+ name: 'All scripts in this project'
+ autoSelect: nil
+
+ "
+ ActiveWorld presenter browseAllScriptsTextually
+ "!
- browseAllScriptsTextually!
Item was changed:
----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'ProjectView' translatedNoop!
- ^ 'ProjectView'!
Item was changed:
----- 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' translatedNoop
- label: 'load as project'
selector: #openFromDirectoryAndFileName:
+ description: 'open project from file' translatedNoop
+ buttonLabel: 'load' translatedNoop
- description: 'open project from file'
- buttonLabel: 'load'
)
argumentGetter: [ :fileList | fileList dirAndFileName]!
Item was changed:
----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
+ "Accept -- in a custom sense here -- a morph dropped on the receiver."
| 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 dropEnabled ifFalse:
+ [^ 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.
- 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 changed:
----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
dismissViaHalo
+ "The user clicked on the dismiss icon on the halo."
+
| choice |
+ project ifNil: [^ self delete]. "no current project"
+ choice := (PopUpMenu labelArray:{
+ 'yes - delete icon and remove the project' translated.
+ 'no - delete icon but keep the project' translated.
+ 'cancel - do not delete anything' translated.
+ }) startUpWithCaption: ('Do you really want to delete the
+ project named {1}
+ and all its contents?' translated format: {project name printString}).
+ choice = 1 ifTrue: [^ self expungeProject].
+ choice = 2 ifTrue: [^ self delete]!
- 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 changed:
----- 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' translated
- ^self inform: 'The project is not present and may not be renamed now'
].
self addProjectNameMorph launchMiniEditor: evt.!
Item was changed:
----- 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' translated]].
- 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 changed:
----- Method: ProjectViewMorph>>fontForName (in category 'drawing') -----
fontForName
+ ^(TextStyle default fontOfSize: 15) emphasized: 1
- | 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 changed:
----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver."
+
super initialize.
+ "currentBorderColor _ Color gray."
+ self addProjectNameMorphFiller.
+ self enableDragNDrop: true.
+ self isOpaque: true.
+ !
- "currentBorderColor := Color gray."
- self addProjectNameMorphFiller.!
Item was changed:
----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
+ "Answer if the receiver would accept a drop of a given morph."
+ "If drop-enabled not set, answer false"
+ (super wantsDroppedMorph: aMorph event: evt) ifFalse: [^ false].
+
+ "If project not present, not morphic, or not initialized, answer false"
+ self isTheRealProjectPresent ifFalse: [^ false].
+ project isMorphic ifFalse: [^ false].
+ project world viewBox ifNil: [^ false].
+
+ ^ true!
- self isTheRealProjectPresent ifFalse: [^false].
- project isMorphic ifFalse: [^false].
- project world viewBox ifNil: [^false]. "uninitialized"
- ^true!
Item was changed:
----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Rectangle' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'A rectangular shape, with border and fill style' translatedNoop!
- ^ self partName: 'Rectangle'
- categories: #('Graphics' 'Basic')
- documentation: 'A rectangular shape, with border and fill style'!
Item was changed:
----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') -----
roundRectPrototype
+ "Answer a prototypical RoundRect object for a parts bin."
+
^ self authoringPrototype useRoundedCorners
+ color: (Color r: 1.0 g: 0.3 b: 0.6);
- color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5);
borderWidth: 1;
setNameTo: 'RoundRect'!
Item was changed:
----- 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].
+ (self valueOfProperty: #withMenuButton) == false ifTrue: [^ nil].
+ menu _ MenuMorph new defaultTarget: model.
+ aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
- menu := MenuMorph new defaultTarget: model.
- aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
getMenuSelector numArgs = 1 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu.
- [aMenu := model perform: getMenuSelector with: menu.
aTitle ifNotNil: [aMenu addTitle: aTitle].
^ aMenu].
getMenuSelector numArgs = 2 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
- [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 changed:
----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Selection' translatedNoop!
- ^ 'Selection'!
Item was changed:
----- 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}.
+ #-.
+ {'distribute vertically' translated. #distributeVertically}.
+ {'distribute horizontally' translated. #distributeHorizontally}.
+ }
- }.
+
- self selectedItems size > 2
- ifTrue:[
- aMenu addList: {
- #-.
- {'distribute vertically' translated. #distributeVertically}.
- {'distribute horizontally' translated. #distributeHorizontally}.
- }.
- ].
!
Item was changed:
----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
+ selectedItems do: [:m | m dismissViaHalo].
-
super dismissViaHalo.
+ !
- selectedItems do: [:m | m dismissViaHalo]!
Item was changed:
----- Method: SelectionMorph>>extent: (in category 'geometry') -----
extent: newExtent
+ "Set the receiver's extent Extend or contract the receiver's selection to encompass morphs within the new extent."
super extent: newExtent.
+ self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])!
- self selectSubmorphsOf: self pasteUpMorph!
Item was changed:
----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: evt
+ "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
selectedItems isEmpty ifTrue:
["Hand just clicked down to draw out a new selection"
^ self extendByHand: evt hand].
+ dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
- 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)] fixTemps].
+ selectedItems _ nil.
+ self removeHalo.
+ self halo ifNotNil: [self halo visible: false].
+ self delete.
- (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
evt wasHandled: true!
Item was changed:
----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') -----
selectSubmorphsOf: aMorph
+ "Given the receiver's current bounds, select submorphs of the indicated pasteup morph that fall entirely within those bounds. If nobody is within the bounds, delete the receiver."
| newItems removals |
+ newItems _ aMorph submorphs select:
- newItems := aMorph submorphs select:
[:m | (bounds containsRect: m fullBounds)
and: [m~~self
and: [(m isKindOf: HaloMorph) not]]].
+ otherSelection ifNil: [^ selectedItems _ newItems].
- otherSelection ifNil: [^ selectedItems := newItems].
+ removals _ newItems intersection: itemsAlreadySelected.
- removals := newItems intersection: itemsAlreadySelected.
otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
+ selectedItems _ (newItems copyWithoutAll: removals).
+ selectedItems ifEmpty: [self delete]
- selectedItems := (newItems copyWithoutAll: removals).
!
Item was changed:
----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') -----
slideToTrash: evt
self delete.
+ "selectedItems do: [:m | m slideToTrash: evt]"!
- selectedItems do: [:m | m slideToTrash: evt]!
Item was changed:
----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
hasContentsInExplorer
+ ^self notEmpty!
- ^self isEmpty not!
Item was changed:
----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
^ self = SimpleButtonMorph
+ ifTrue: ['Button' translatedNoop]
- ifTrue: ['Button']
ifFalse: [^ super defaultNameStemForInstances]!
Item was changed:
----- 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 action selector' translated action: #setActionSelector.
aCustomMenu add: 'change arguments' translated action: #setArguments.
aCustomMenu add: 'change when to act' translated action: #setActWhen.
+ aCustomMenu add: 'set target' translated action: #sightTargets:.
+ target ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]].
- self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
!
Item was changed:
----- 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:
+ [target perform: actionSelector withArguments: arguments].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments]].
actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]!
Item was changed:
----- 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."
+ ^ super 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.
+ Feb 2007: It seems unlikely that Squeak Pages will be used in the OLPC image. Don't use this code. Consider removing all code that supports SqueakPages."
+ "
| bb thatPage um stem ind sqPg |
(actionSelector == #goToPageMorph:fromBookmark:) |
(actionSelector == #goToPageMorph:) ifFalse: [
+ ^ super objectForDataStream: refStrm]. 'normal case'.
- ^ super objectForDataStream: refStrm]. "normal case"
+ target url ifNil: ['Later force target book to get a url.'.
+ bb _ SimpleButtonMorph new. 'write out a dummy'.
- 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.
- (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.
- 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.
- 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'.
- 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
+ "!
- ^ um!
Item was changed:
----- Method: SimpleButtonMorph>>updateVisualState: (in category 'visual properties') -----
updateVisualState: evt
oldColor ifNotNil: [
self color:
((self containsPoint: evt cursorPoint)
+ ifTrue: [oldColor mixed: 0.5 with: Color white]
- ifTrue: [oldColor mixed: 1/2 with: Color white]
ifFalse: [oldColor])]
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ self setProperty: #autoExpand toValue: false.
self
on: #mouseMove
send: #mouseStillDown:onItem:
to: self!
Item was changed:
----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Sketch' translatedNoop!
- ^ 'Sketch'!
Item was changed:
----- Method: SketchMorph>>addToggleItemsToHaloMenu: (in category 'menus') -----
addToggleItemsToHaloMenu: aCustomMenu
+ "Add toggle-items to the halo menu"
+
- "Add toggle-items to the halo menu"
super addToggleItemsToHaloMenu: aCustomMenu.
+ (Smalltalk includesKey: #B3DRenderEngine) ifTrue: [
+ aCustomMenu addUpdating: #useInterpolationString target: self action: #toggleInterpolation.
+ ].
+ !
- Preferences noviceMode
- ifFalse: [""aCustomMenu
- addUpdating: #useInterpolationString
- target: self
- action: #toggleInterpolation]!
Item was changed:
----- Method: SketchMorph>>collapse (in category 'menus') -----
collapse
+ "Replace the receiver with a collapsed rendition of itself."
-
- | priorPosition w collapsedVersion a |
+ | w collapsedVersion a ht tab |
+
+ (w _ self world) ifNil: [^self].
+ collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
- (w := self world) ifNil: [^self].
- collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph.
collapsedVersion setProperty: #uncollapsedMorph toValue: self.
collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
+
+ collapsedVersion setBalloonText: ('A collapsed version of {1}. Click to open it back up.' translated format: {self externalName}).
+
- collapsedVersion setBalloonText: 'A collapsed version of ',self name.
-
self delete.
w addMorphFront: (
+ a _ AlignmentMorph newRow
- a := AlignmentMorph newRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 4;
borderColor: Color white;
+ addMorph: collapsedVersion;
+ yourself).
+ a setNameTo: self externalName.
+ ht := (tab := ActiveWorld findA: SugarNavTab)
+ ifNotNil:
+ [tab height]
+ ifNil:
+ [80].
+ a position: 0@ht.
+
- addMorph: collapsedVersion
- ).
collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+ (self valueOfProperty: #collapsedPosition) ifNotNilDo:
+ [:priorPosition |
+ a position: priorPosition]!
- (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil])
- ifNotNil:
- [a position: priorPosition].
- !
Item was changed:
----- 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 x = 0 or: [newExtent y = 0]) ifTrue: [ ^self ].
- newExtent isZero ifTrue: [ ^self ].
self extent = newExtent ifTrue:[^self].
self scalePoint: newExtent asFloatPoint / (originalForm extent max: 1@1).
self layoutChanged.
!
Item was changed:
----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') -----
flipHorizontal
+ | r |
+ r _ self rotationCenter.
+ self left: self left - (1.0 - (2 * r x) * self width).
+ self form: (self form flipBy: #horizontal centerAt: self form center).
+ self rotationCenter: (1 - r x) @ (r y).!
- self form: (self form flipBy: #horizontal centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>flipVertical (in category 'e-toy support') -----
flipVertical
+ | r |
+ r _ self rotationCenter.
+ self top: self top - (1.0 - (2 * r y) * self height).
+ self form: (self form flipBy: #vertical centerAt: self form center).
+ self rotationCenter: r x @ (1 - r y).!
- self form: (self form flipBy: #vertical centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>initializeWith: (in category 'initialization') -----
initializeWith: aForm
super initialize.
+ originalForm _ aForm.
+ rotationStyle _ #normal. "styles: #normal, #leftRight, #upDown, or #none"
+ scalePoint _ 1.0(a)1.0.
+ framesToDwell _ 1.
+ rotatedForm _ originalForm. "cached rotation of originalForm"
- originalForm := aForm.
- self rotationCenter: 0.5(a)0.5. "relative to the top-left corner of the Form"
- rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none"
- scalePoint := 1.0(a)1.0.
- framesToDwell := 1.
- rotatedForm := originalForm. "cached rotation of originalForm"
self extent: originalForm extent.
!
Item was changed:
----- 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
+ Because my rendering code flips the form (see generateRotatedForm) we 'pre-flip' it here to preserve the same visual appearance.
+ "
- #none -- do not rotate"
+ | wasFlippedX wasFlippedY isFlippedX isFlippedY |
+ wasFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ wasFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ rotationStyle _ aSymbol.
+
+ isFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ isFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ wasFlippedX == isFlippedX
+ ifFalse: [self form: (self form flipBy: #horizontal centerAt: self form center)].
+ wasFlippedY == isFlippedY
+ ifFalse: [self form: (self form flipBy: #vertical centerAt: self form center)].
+
- rotationStyle := aSymbol.
self layoutChanged.
!
Item was changed:
----- Method: Slider>>sliderThickness (in category 'geometry') -----
sliderThickness
+ "^ 7"
+
+ | w |
+ w _ bounds isWide
+ ifTrue: [super height]
+ ifFalse: [super width].
+
+ ^ (w // 32) max: 16.
+ !
- ^ 7!
Item was changed:
----- 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: [FormDictionary at: #Cat]].
+ ^ FormDictionary at: #Cat!
- [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
- ^ nil!
Item was changed:
----- 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.
+ aCustomMenu addUpdating: #usePangoString target: self action: #toggleUsePango.
!
Item was changed:
----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
addOptionalHandlesTo: aHalo box: box
+ "eventually, add more handles for font..."
+
self flag: #deferred.
+ ^ super addOptionalHandlesTo: aHalo box: box
"Eventually...
self addFontHandlesTo: aHalo box: box"!
Item was changed:
----- 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 projectParameterAt: #substitutedFont).
+ (substituteFont notNil and: [self font == substituteFont])
- substituteFont := aProject projectParameters at:
- #substitutedFont ifAbsent: [#none].
- (substituteFont ~~ #none and: [self font == substituteFont])
ifTrue: [ self fitContents ].
^ super fixUponLoad: aProject seg: anImageSegment!
Item was changed:
----- Method: StringMorph>>font: (in category 'printing') -----
font: aFont
"Set the font my text will use. The emphasis remains unchanged."
+ aFont = font ifTrue: [^ self].
+ font _ aFont.
- font := aFont.
^ self font: font emphasis: emphasis!
Item was changed:
----- Method: StringMorphEditor>>initialize (in category 'display') -----
initialize
"Initialize the receiver. Give it a white background"
super initialize.
self backgroundColor: Color white.
+ self textColor: Color red.!
- self color: Color red!
Item was changed:
----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'TrueType banner' translatedNoop
+ categories: #()
+ documentation: 'A short text in a beautiful font. Use the resize handle to change size.' translatedNoop!
- ^ self partName: 'TrueType banner'
- categories: #('Demo')
- documentation: 'A short text in a beautiful font. Use the resize handle to change size.'!
Item was changed:
----- 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' translatedNoop. 'A scrolling data field which will have a different value on every card of the background' translatedNoop}
- 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 changed:
----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') -----
borderedPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t fontName: 'BitstreamVeraSans' pointSize: 24.
t autoFit: false; extent: 250@100.
+ t borderWidth: 1; margins: 4@0; backgroundColor: Color white.
- t borderWidth: 1; margins: 4@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 changed:
----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Text' translatedNoop!
- ^ 'Text'!
Item was changed:
----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') -----
fancyPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t autoFit: false; extent: 150@75.
t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?"
"fancy font, shadow, rounded"
+ t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; fillStyle: Color lightBrown.
- 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 changed:
----- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- 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' translatedNoop. 'A piece of text that will occur on every card of the background' translatedNoop}
- 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' translatedNoop. 'A data field which will have a different value on every card of the background' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you wish' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish')
forFlapNamed: 'Stack Tools'.
+ cl registerQuad: {#TextMorph . #fancyPrototype. 'Fancy Text' translatedNoop. 'A text field with a rounded shadowed border, with a fancy font.' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
forFlapNamed: 'Supplies'.]!
Item was changed:
----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+ (self backgroundColor isNil or: [self backgroundColor asColor isTranslucent])
- (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 changed:
----- Method: TextMorph>>backgroundColor (in category 'accessing') -----
backgroundColor
+ ^ self fillStyle.
+ !
- ^ backgroundColor!
Item was changed:
----- Method: TextMorph>>backgroundColor: (in category 'accessing') -----
backgroundColor: newColor
+ self fillStyle: newColor.
+ !
- backgroundColor := newColor.
- self changed!
Item was changed:
----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
beAllFont: aFont
+ textStyle _ TextStyle fontArray: (Array with: aFont).
+ text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)].
- textStyle := TextStyle fontArray: (Array with: aFont).
self releaseCachedState; changed!
Item was changed:
----- Method: TextMorph>>defaultLineHeight (in category 'geometry') -----
defaultLineHeight
+ ^ ( textStyle fontAt: textStyle defaultFontIndex) pointSize!
- ^ textStyle lineGrid!
Item was changed:
----- 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 wid |
- | newExtent para cBounds lastOfLines heightOfLast |
self isAutoFit
ifTrue:
+ [wid _ (text notNil and: [text size > 2]) ifTrue: [5] ifFalse: [40].
+ newExtent := (self paragraph extent max: wid @ ( self defaultLineHeight)) + (0 @ 2).
- [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 changed:
----- Method: TextMorph>>insertCharacters: (in category 'scripting access') -----
+ insertCharacters: aString
- insertCharacters: aSource
"Insert the characters from the given source at my current cursor position"
+ | aLoc aText attributes |
- | aLoc |
aLoc := self cursor max: 1.
+ aText := aLoc > text size
+ ifTrue: [aString asText]
+ ifFalse: [
+ attributes := (text attributesAt: aLoc)
+ select: [:attr | attr mayBeExtended].
+ Text string: aString attributes: attributes].
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aText displaying: true.
- paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
self updateFromParagraph !
Item was changed:
----- 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].
- [paragraph := nil].
container ifNotNil:
+ [container isMorph ifTrue: [container releaseCachedState]]!
- [container releaseCachedState]!
Item was changed:
----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') -----
setAllButFirstCharacter: source
"Set all but the first char of the receiver to the source"
+ | chars |
+ (chars _ self getCharacters) isEmpty
- | aChar chars |
- aChar := source asCharacter.
- (chars := self getCharacters) isEmpty
ifTrue: [self newContents: 'ยท' , source asString]
+ ifFalse: [self newContents: (String
- ifFalse: [chars first = aChar
- ifFalse: [""
- self
- newContents: (String
streamContents: [:aStream |
aStream nextPut: chars first.
+ aStream nextPutAll: source])]!
- aStream nextPutAll: source])]] !
Item was changed:
----- Method: TextMorph>>textColor: (in category 'accessing') -----
textColor: aColor
+ self editor selectFrom: 1 to: 0.
+ self selectionColor: aColor.
- color = aColor ifTrue: [^ self].
- color := aColor.
- self changed.
!
Item was changed:
----- Method: TheWorldMenu>>remoteMenu (in category 'construction') -----
remoteMenu
"Build the Telemorphic menu for the world."
+ ^self fillIn: (self menu: 'Telemorphic' translatedNoop) from: {
+ { 'local host address' translatedNoop. { #myWorld . #reportLocalAddress } }.
+ { 'connect remote user' translatedNoop. { #myWorld . #connectRemoteUser } }.
+ { 'disconnect remote user' translatedNoop. { #myWorld . #disconnectRemoteUser } }.
+ { 'disconnect all remote users' translatedNoop. { #myWorld . #disconnectAllRemoteUsers } }.
- ^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 changed:
----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') -----
windowsMenu
"Build the windows menu for the world."
+ ^ self fillIn: (self menu: 'windows' translatedNoop) from: {
+ { 'find window' translatedNoop. { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' translatedNoop}.
- ^ 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...' translatedNoop. { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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...' translatedNoop. { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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.' translatedNoop}.
- tile: new windows positioned so that they do not overlap others, if possible.'}.
nil.
+ { 'collapse all windows' translatedNoop. { #myWorld . #collapseAllWindows }. 'Reduce all open windows to collapsed forms that only show titles.' translatedNoop}.
+ { 'collapse all objects' translatedNoop. { #myWorld . #collapseAllWindowsAndNonWindows }. 'Reduce all open windows and all other objects on the desktop to labeled tabs' translatedNoop}.
+ { 'expand all' translatedNoop. { #myWorld . #expandAllCollapsedObjects }. 'Expand all collapsed windows and other collapsed objects back to their expanded forms.' translatedNoop}.
+
+ { 'close top window (w)' translatedNoop. { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.' translatedNoop}.
+ { 'send top window to back (\)' translatedNoop. { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.' translatedNoop}.
+ { 'move windows onscreen' translatedNoop. { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen' translatedNoop}.
- { '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' translatedNoop. { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.' translatedNoop}.
+ { 'delete non-windows' translatedNoop. { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.' translatedNoop}.
+ { 'delete both of the above' translatedNoop. { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' translatedNoop}.
- { '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 changed:
----- 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."
+ | args |
(target notNil and: [actionSelector notNil])
ifTrue:
+ [args := actionSelector numArgs > arguments size
+ ifTrue:
+ [arguments copyWith: ActiveEvent]
+ ifFalse:
+ [arguments].
+ Cursor normal
+ showWhile: [target perform: actionSelector withArguments: args].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments].
target isMorph ifTrue: [target changed]]!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| now dt |
- self state: #pressed.
actWhen == #buttonDown
+ ifTrue: [self doButtonAction].
+ actWhen == #buttonUp
+ ifTrue: [self state: #pressed].
+ actWhen == #whilePressed
+ ifTrue:
+ [self state: #pressed.
+ now _ Time millisecondClockValue.
- 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"
+ "NOTE: this delay is temporary disabled because it makes event reaction delay,
+ e.g. the action is not stopped even if you release the button... - Takashi"
+ [dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
+ self mouseStillDown: evt].
+ super mouseDown: evt!
- dt := Time millisecondClockValue - now max: 0. "Time it took to do"
- dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
- self mouseStillDown: evt.!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ (#(#buttonUp #whilePressed ) includes: actWhen)
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #pressed]
+ ifFalse: [self state: #off]].
+ super mouseMove: evt!
- 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 changed:
----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
- mouseUp: evt
"Allow on:send:to: to set the response to events other than actWhen"
+ actWhen == #buttonDown
+ ifTrue: [super mouseUp: evt].
+ actWhen == #buttonUp
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #on.
+ self doButtonAction: evt.
+ super mouseUp: evt]
+ ifFalse: [self state: #off.
+ target
+ ifNotNil: ["Allow owner to keep it selected for radio
+ buttons"
+ target mouseUpBalk: evt]]].
+ actWhen == #whilePressed
+ ifTrue: [self state: #off.
+ super mouseUp: evt]!
- 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 changed:
----- 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: [1]
- ifTrue: [ 2]
ifFalse: [1]!
Item was changed:
----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') -----
fitContents
+ | newExtent |
+ newExtent := self measureContents.
+ newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.
- | 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 changed:
----- Method: UpdatingStringMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver to have default values in its instance variables."
- "Initialie the receiver to have default values in its instance
- variables "
super initialize.
""
+ format _ #default.
- format := #default.
"formats: #string, #default"
+ target _ getSelector _ putSelector _ nil.
+ floatPrecision _ 1.
+ growable _ true.
+ stepTime _ nil.
+ autoAcceptOnFocusLoss _ true.
+ minimumWidth _ 8.
+ maximumWidth _ 366!
- target := getSelector := putSelector := nil.
- floatPrecision := 1.
- growable := true.
- stepTime := 50.
- autoAcceptOnFocusLoss := true.
- minimumWidth := 8.
- maximumWidth := 300!
Item was changed:
----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') -----
readFromTarget
"Update my readout from my target"
+ | v ret places |
- | v ret |
(target isNil or: [getSelector isNil]) ifTrue: [^contents].
+ ret _ self checkTarget.
- ret := self checkTarget.
ret ifFalse: [^ '0'].
+ ((target isMorph) or:[target isPlayerLike]) ifTrue:[
+ places _ target decimalPlacesForGetter: getSelector.
+ (places ~= nil and: [ places ~= (self valueOfProperty: #decimalPlaces ifAbsent: [0])]) ifTrue: [ self decimalPlaces: places ]].
v := target perform: getSelector. "scriptPerformer"
(v isKindOf: Text) ifTrue: [v := v asString].
^self acceptValueFromTarget: v!
Item was changed:
----- 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 := MenuMorph new.
aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
+ 0 to: 10 do:
- 0 to: 5 do:
[:places |
aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
aMenu popUpInWorld!
Item was changed:
----- Method: UpdatingStringMorph>>stepTime (in category 'testing') -----
stepTime
+ ^ stepTime ifNil: [200]
- ^ stepTime ifNil: [50]
!
Item was changed:
----- 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.
+ self setProperty: #decimalPlaces toValue: ((self valueOfProperty: #decimalPlaces ifAbsent: [0]) veryDeepCopyWith: 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.
!
1
0
Tim Felgentreff uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-tfel.1247.mcz
==================== Summary ====================
Name: Morphic-tfel.1247
Author: tfel
Time: 10 August 2016, 9:44:58.174314 am
UUID: f3b477b4-413c-2146-b1cd-7e517025b930
Ancestors: Morphic-mt.1246, Morphic-tfel.1244
merge with trunk
=============== Diff against Morphic-mt.1246 ===============
Item was changed:
----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
supplementaryPartsDescriptions
"Extra items for parts bins"
^ {DescriptionForPartsBin
+ formalName: 'Circle' translatedNoop
+ categoryList: {'Graphics' translatedNoop}
+ documentation: 'A circular shape' translatedNoop
- formalName: 'Circle1'
- categoryList: #('Graphics')
- documentation: 'A circular shape'
globalReceiverSymbol: #CircleMorph
nativitySelector: #newStandAlone.
+ DescriptionForPartsBin
+ formalName: 'Pin' translatedNoop
+ categoryList: {'Connectors' translatedNoop}
+ documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop
- "DescriptionForPartsBin
- formalName: 'Pin'
- categoryList: #('Connectors')
- documentation: 'An attachment point for Connectors that you can embed in another Morph.'
globalReceiverSymbol: #NCPinMorph
+ nativitySelector: #newPin.
- nativitySelector: #newPin."
}!
Item was changed:
SketchMorph subclass: #ColorPickerMorph
+ instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency noChart'
+ classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransparentBox TransText'
- 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 changed:
----- 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 @ 31. "<<<< the form was changed a bit??"
- 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 changed:
----- 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 insetBy: 2) fillColor: feedbackColor.
- originalForm fill: FeedbackBox fillColor: feedbackColor.
self form: originalForm.
+ selectedColor _ aColor.
- selectedColor := aColor.
updateContinuously ifTrue: [self updateTargetColor].
self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).!
Item was changed:
----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Ellipse' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'An elliptical or circular shape' translatedNoop!
- ^ self partName: 'Ellipse'
- categories: #('Graphics' 'Basic')
- documentation: 'An elliptical or circular shape'!
Item was changed:
----- Method: HaloMorph>>addDupHandle: (in category 'handles') -----
addDupHandle: haloSpec
"Add the halo that offers duplication, or, when shift is down, make-sibling"
+ | aSelector |
+ aSelector := innerTarget couldMakeSibling
+ ifTrue:
+ [#doDupOrMakeSibling:with:]
+ ifFalse:
+ [#doDup:with:].
- self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self
+ self addHandle: haloSpec on: #mouseDown send: aSelector to: self
+
!
Item was changed:
----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') -----
addHandlesForWorldHalos
"Add handles for world halos, like the man said"
| box w |
+ w _ self world ifNil:[target world].
- w := self world ifNil:[target world].
self removeAllMorphs. "remove old handles, if any"
self bounds: target bounds.
+ box _ w bounds insetBy: self handleSize // 2.
- box := w bounds insetBy: 9.
target addWorldHandlesTo: self box: box.
Preferences uniqueNamesInHalos ifTrue:
[innerTarget assureExternalName].
self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
+ growingOrRotating _ false.
- growingOrRotating := false.
self layoutChanged.
self changed.
!
Item was changed:
----- Method: HaloMorph>>addViewingHandle: (in category 'handles') -----
addViewingHandle: haloSpec
+ "If appropriate, add a special Viewing halo handle to the receiver. On 26 Sept 07, we decided to eliminate this item from the UI, so the code of is method is now commented out...
- "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 changed:
----- Method: HaloMorph>>basicBox (in category 'private') -----
basicBox
| aBox minSide anExtent w |
+ minSide _ 4 * self handleSize.
+ anExtent _ ((self width + self handleSize + 8) max: minSide) @
- 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].
- aBox := Rectangle center: self center extent: anExtent.
- w := self world ifNil:[target outermostWorldMorph].
^ w
ifNil:
[aBox]
ifNotNil:
+ [aBox intersect: (w viewBox insetBy: self handleSize // 2)]
- [aBox intersect: (w viewBox insetBy: 8@8)]
!
Item was changed:
----- Method: HaloMorph>>doDirection:with: (in category 'private') -----
doDirection: anEvent with: directionHandle
+ "The mouse went down on the forward-direction halo handle; respond appropriately."
+
anEvent hand obtainHalo: self.
+ anEvent shiftPressed
+ ifTrue:
+ [directionArrowAnchor _ (target point: target referencePosition in: self world) rounded.
+ self positionDirectionShaft: directionHandle.
+ self removeAllHandlesBut: directionHandle.
+ directionHandle setProperty: #trackDirectionArrow toValue: true]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: directionHandle]!
- self removeAllHandlesBut: directionHandle!
Item was changed:
----- Method: HaloMorph>>handleSize (in category 'private') -----
handleSize
^ Preferences biggerHandles
+ ifTrue: [30]
- ifTrue: [20]
ifFalse: [16]!
Item was changed:
----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') -----
prepareToTrackCenterOfRotation: evt with: rotationHandle
+ "The mouse went down on the center of rotation."
+
evt hand obtainHalo: self.
+ evt shiftPressed
+ ifTrue:
+ [self removeAllHandlesBut: rotationHandle.
+ rotationHandle setProperty: #trackCenterOfRotation toValue: true.
+ evt hand showTemporaryCursor: Cursor blank]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: rotationHandle]!
- evt shiftPressed ifTrue:[
- self removeAllHandlesBut: rotationHandle.
- ] ifFalse:[
- rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
- self startDrag: evt with: rotationHandle
- ].
- evt hand showTemporaryCursor: Cursor blank!
Item was changed:
----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') -----
setCenterOfRotation: evt with: rotationHandle
| localPt |
evt hand obtainHalo: self.
evt hand showTemporaryCursor: nil.
+ (rotationHandle hasProperty: #trackCenterOfRotation) ifTrue:
+ [localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
+ innerTarget setRotationCenterFrom: localPt].
+
+ rotationHandle removeProperty: #trackCenterOfRotation.
+ self endInteraction!
- (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
- localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
- innerTarget setRotationCenterFrom: localPt.
- ].
- rotationHandle removeProperty: #dragByCenterOfRotation.
- self endInteraction
- !
Item was changed:
----- 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"
+ (directionHandle hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ target setDirectionFrom: directionHandle center.
+ directionHandle removeProperty: #trackDirectionArrow.
+ self endInteraction]!
- anEvent hand obtainHalo: self.
- target setDirectionFrom: directionHandle center.
- self endInteraction!
Item was changed:
----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') -----
trackCenterOfRotation: anEvent with: rotationHandle
(rotationHandle hasProperty: #dragByCenterOfRotation)
ifTrue:[^self doDrag: anEvent with: rotationHandle].
+ (rotationHandle hasProperty: #trackCenterOfRotation)
+ ifTrue:
+ [anEvent hand obtainHalo: self.
+ rotationHandle center: anEvent cursorPoint]!
- anEvent hand obtainHalo: self.
- rotationHandle center: anEvent cursorPoint.!
Item was changed:
----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') -----
trackDirectionArrow: anEvent with: shaft
+ (shaft hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
+ self layoutChanged]!
- anEvent hand obtainHalo: self.
- shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
- self layoutChanged!
Item was changed:
----- Method: HandleMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self extent: 16 @ 16.
- self extent: 8 @ 8.
!
Item was changed:
----- Method: IconicButton>>stationarySetup (in category 'initialization') -----
stationarySetup
+ "Set up event handlers for mouse actions. Should be spelled stationery..."
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.
+
+ self on: #click send: #launchPartFromClick to: self!
- self on: #mouseUp send: #borderThick to: self.!
Item was changed:
----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Image' translatedNoop
+ categories: #()
+ documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.' translatedNoop!
- ^ 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 changed:
----- 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' translatedNoop. 'A non-editable picture of something' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Joystick' translatedNoop
+ categories: {'Basic' translatedNoop}
+ documentation: 'A joystick-like control' translatedNoop!
- ^ self partName: 'Joystick'
- categories: #('Useful')
- documentation: 'A joystick-like control'!
Item was changed:
----- 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' translatedNoop. 'A joystick-like control' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Scripting'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ "Answer a description for the parts bin."
+
+ ^ self partName: 'Line' translatedNoop
+ categories: {'Graphics' translatedNoop}
+ documentation: 'A straight line. Shift-click to get handles and move the ends.' translatedNoop!
- ^ self partName: 'Line'
- categories: #('Graphics' 'Basic')
- documentation: 'A straight line. Shift-click to get handles and move the ends.'!
Item was changed:
----- 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.
- ActiveWorld addMorph: self centeredNear: aPoint.
self world displayWorld. "show myself"
+ aBlock value]
+ ensure: [self delete]!
- aBlock value.
- self delete!
Item was changed:
----- Method: MenuIcons class>>iconForMenuItem: (in category 'menu decoration') -----
iconForMenuItem: anItem
+ "Answer the icon (or nil) corresponding to a given menu item."
- "Answer the icon (or nil) corresponding to the (translated) string."
+ | aKey |
+ aKey _ (anItem selector == #undoOrRedoCommand)
+ ifTrue:
+ ['undo (z)' translated] "Actual wording changes dynamically"
+ ifFalse:
+ [anItem contents asString].
+ ^ TranslatedIcons at: aKey asLowercase ifAbsent: [nil]!
- ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]!
Item was changed:
----- Method: MenuMorph>>delete (in category 'initialization') -----
delete
+ "Delete the receiver."
+
+ activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]].
+ self isFlexed ifTrue: [^ owner delete].
+ ^ super delete!
- activeSubMenu ifNotNil:[activeSubMenu delete].
- ^super delete!
Item was changed:
----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') -----
serviceLoadMorphFromFile
"Answer a service for loading a .morph file"
^ SimpleServiceEntry
provider: self
+ label: 'load as morph' translatedNoop
- label: 'load as morph'
selector: #fromFileName:
+ description: 'load as morph' translatedNoop
+ buttonLabel: 'load' translatedNoop!
- description: 'load as morph'
- buttonLabel: 'load'!
Item was changed:
----- 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 w |
+ menu _ MenuMorph new defaultTarget: self.
+ w _ self world.
+ self potentialEmbeddingTargets reverseDo: [:m |
+ menu add: (m == w ifTrue: ['desktop' translated] ifFalse: [m knownName ifNil:[m class name asString]]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}.
+ m == self topRendererOrSelf owner ifTrue:
+ [menu lastItem color: Color red]].
+ aMenu ifNotNil:
+ [menu submorphCount > 0
+ ifTrue:[aMenu add:'embed into' translated subMenu: 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 changed:
----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') -----
addFlexShell
"Wrap a rotating and scaling shell around this morph."
+ | oldHalo flexMorph myWorld anIndex morphOwner |
- | oldHalo flexMorph myWorld anIndex |
myWorld := self world.
+ oldHalo:= self halo.
+ self owner ifNotNil:[ morphOwner := self owner]
+ ifNil:[morphOwner := self currentWorld].
+
+ anIndex := morphOwner submorphIndexOf: self.
+ morphOwner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self)
- 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 changed:
----- Method: Morph>>addHaloActionsTo: (in category 'menus') -----
addHaloActionsTo: aMenu
"Add items to aMenu representing actions requestable via halo"
| subMenu |
+ subMenu _ MenuMorph new defaultTarget: self.
- 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 add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles.
subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.
+ subMenu add: 'tile representing this object' translated target: self action: #tearOffTile.
- 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 changed:
----- 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 notNil and: [aNumber <= submorphs size])
- (aNumber <= submorphs size)
ifTrue:
[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
ifFalse:
+ [self addMorphBack: aMorph]!
- [self addMorphBack: aMorph]
- !
Item was changed:
----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') -----
chooseNewGraphicCoexisting: aBoolean
"Allow the user to choose a different form for her form-based morph"
+
| replacee aGraphicalMenu |
+ self isInWorld ifFalse: "menu must have persisted for a not-in-world object."
+ [aGraphicalMenu := ActiveWorld submorphThat:
+ [:m | (m isKindOf: GraphicalMenu) and: [m target == self]]
+ ifNone:
+ [^ self].
+ ^ aGraphicalMenu show; flashBounds].
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 changed:
----- Method: Morph>>couldMakeSibling (in category 'testing') -----
couldMakeSibling
"Answer whether it is appropriate to ask the receiver to make a sibling"
+ ^ self isWorldMorph not!
- ^ true!
Item was changed:
----- Method: Morph>>goBehind (in category 'submorphs-add/remove') -----
goBehind
+ "Move the receiver to bottom z-order."
+ | topRend |
+ topRend := self topRendererOrSelf.
+ topRend owner ifNotNilDo:
+ [:own | own addMorphNearBack: topRend]
- owner addMorphNearBack: self.
!
Item was changed:
----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') -----
invokeMetaMenu: evt
+ "Put up the 'meta' menu, invoked via control-click, unless eToyFriendly is true."
+
| menu |
+ Preferences eToyFriendly ifTrue: [^ self].
+
+ menu _ self buildMetaMenu: evt.
- menu := self buildMetaMenu: evt.
menu addTitle: self externalName.
+ menu popUpEvent: evt in: self world!
- self world ifNotNil: [
- menu popUpEvent: evt in: self world
- ]!
Item was changed:
----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') -----
obtrudesBeyondContainer
"Answer whether the receiver obtrudes beyond the bounds of its container"
+ | top formerOwner |
- | top |
top := self topRendererOrSelf.
+ top owner ifNil: [^ false].
+ ^ top owner isHandMorph
+ ifTrue:
+ [((formerOwner := top formerOwner) notNil and: [formerOwner isInWorld])
+ ifFalse:
+ [false]
+ ifTrue:
+ [(formerOwner boundsInWorld containsRect: top boundsInWorld) not]]
+ ifFalse:
+ [(top owner bounds containsRect: top bounds) not]!
- (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
- ^(top owner bounds containsRect: top bounds) not!
Item was changed:
----- Method: Morph>>on:send:to: (in category 'event handling') -----
on: eventName send: selector to: recipient
+ "When the given event occurs, send the given selector to the given recipient. If the given selector is nil, rescind any earlier handling for the given event type,"
+
+ self eventHandler ifNil:
+ [selector ifNil: [^ self]. "Don't pointlessly create an event handler!!"
+ self eventHandler: EventHandler new].
- self eventHandler ifNil: [self eventHandler: EventHandler new].
self eventHandler on: eventName send: selector to: recipient!
Item was changed:
----- Method: Morph>>openViewerForArgument (in category 'player viewer') -----
openViewerForArgument
+ Cursor wait
+ showWhile: [self presenter viewMorph: self]!
- "Open up a viewer for a player associated with the morph in question. "
- self presenter viewMorph: self!
Item was changed:
----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') -----
overlapsShadowForm: itsShadow bounds: itsBounds
"Answer true if itsShadow and my shadow overlap at all"
+ | overlapExtent overlap myRect myShadow goalRect goalShadow bb |
+ overlap _ self fullBounds intersect: itsBounds.
+ overlapExtent _ overlap extent.
- | andForm overlapExtent |
- overlapExtent := (itsBounds intersect: self fullBounds) extent.
overlapExtent > (0 @ 0)
ifFalse: [^ false].
+ myRect := overlap translateBy: 0 @ 0 - self topLeft.
+ myShadow := (self imageForm contentsOfArea: myRect) stencil.
+ goalRect := overlap translateBy: 0 @ 0 - itsBounds topLeft.
+ goalShadow := (itsShadow contentsOfArea: goalRect) stencil.
+
+ "compute a pixel-by-pixel AND of the two stencils. Result will be black
+ (pixel value = 1) where black parts of the stencils overlap"
+ bb := BitBlt toForm: myShadow.
+ bb
+ copyForm: goalShadow
+ to: 0 @ 0
+ rule: Form and.
+
+ ^(bb destForm tallyPixelValues second) > 0 !
- 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 changed:
----- Method: Morph>>roundUpStrays (in category 'miscellaneous') -----
roundUpStrays
+ "Bring submorphs of playfieldlike structures in the receiver's interior back within view."
+
+ self submorphsDo:
+ [:m | m isPlayfieldLike ifTrue: [m roundUpStrays]]!
- self submorphs
- do: [:each | each roundUpStrays]!
Item was changed:
----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
slideBackToFormerSituation: evt
+ "A drop of the receiver having been rejected, slide it back to where it came from, if possible."
+
| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
formerOwner := self formerOwner.
formerPosition := self formerPosition.
+ (aWorld := evt hand world) ifNil: [^ self delete]. "Likely a moribund hand from an EventRecorder playback."
+
- 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.
+ "The OLPC Virtual Screen wouldn't notice the last update here."
+ Display forceToScreen: (endPoint extent: slideForm extent).
formerOwner addMorph: self.
self position: formerPosition.
self justDroppedInto: formerOwner event: evt!
Item was changed:
----- Method: Morph>>useGradientFill (in category 'visual properties') -----
useGradientFill
"Make receiver use a solid fill style (e.g., a simple color)"
+
+ | fill color1 color2 fil |
+ ((fil := self fillStyle) notNil and: [fil isSymbol not] and: [fil isGradientFill]) ifTrue:[^self]. "Already done"
+ color1 _ self color asColor.
+ color2 _ color1 negated.
+ fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
- | 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 changed:
----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') -----
wantsHaloFromClick
+
+ ^ self valueOfProperty: #wantsHaloFromClick ifAbsent: [^true].!
- ^ true!
Item was changed:
----- Method: MorphicProject>>updateLocaleDependents (in category 'language') -----
updateLocaleDependents
"Set the project's natural language as indicated"
ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
viewerOrScriptor localeChanged].
Flaps disableGlobalFlaps: false.
+ (Preferences eToyFriendly or: [Smalltalk globals at: #SugarNavigatorBar ifPresent: [:c | c showSugarNavigator] ifAbsent: [false]])
- Preferences eToyFriendly
ifTrue: [
Flaps addAndEnableEToyFlaps.
ActiveWorld addGlobalFlaps]
ifFalse: [Flaps enableGlobalFlaps].
(Project current isFlapIDEnabled: 'Navigator' translated)
ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].
ScrapBook default emptyScrapBook.
MenuIcons initializeTranslations.
super updateLocaleDependents.
"self setFlaps.
self setPaletteFor: aLanguageSymbol."
!
Item was changed:
----- 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 := 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 wantsMouseOverHalos: false.
proto beSticky.
^ proto!
Item was changed:
----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
"Answer a basis for names of default instances of the receiver"
+ ^ 'playfield' translatedNoop!
- ^ 'playfield'!
Item was changed:
----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') -----
addPenMenuItems: menu hand: aHandMorph
"Add a pen-trails-within submenu to the given menu"
+ menu add: 'pen trails...' translated target: self selector: #putUpPenTrailsSubmenu.
+ menu balloonTextForLastItem: 'its governing pen trails drawn within' translated!
- menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu!
Item was changed:
----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') -----
addPenTrailsMenuItemsTo: aMenu
"Add items relating to pen trails to aMenu"
| oldTarget |
+ oldTarget _ aMenu defaultTarget.
- 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 addLine.
+ aMenu addUpdating: #batchPenTrailsString action: #toggleBatchPenTrails.
+ aMenu balloonTextForLastItem: 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.' translated.
+
aMenu defaultTarget: oldTarget!
Item was changed:
----- Method: PasteUpMorph>>addWorldToggleItemsToHaloMenu: (in category 'menu & halo') -----
addWorldToggleItemsToHaloMenu: aMenu
+ "Add toggle items for the world to the halo menu .... July 2009: no longer in world halo menu"
- "Add toggle items for the world to the halo menu"
+ "aMenu addUpdating: #showTabsString
+ target: CurrentProjectRefactoring
+ action: #currentToggleFlapsSuppressed "!
- #(
- (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 changed:
----- 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.
+ self changed "redraw"
- self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
!
Item was changed:
----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') -----
chooseClickTarget
Cursor crossHair showWhile:
[Sensor waitButton].
Cursor down showWhile:
[Sensor anyButtonPressed].
+ ^ (self morphsAt: Sensor cursorPoint) first topRendererOrSelf!
- ^ (self morphsAt: Sensor cursorPoint) first!
Item was changed:
----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') -----
correspondingFlapTab
+ "If there is a flap tab whose referent is me, return it, else return nil. Will also work for flaps on the edge of embedded subareas such as within scripting-areas, but more slowly."
+
- "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]].
+
+ "Catch guys in embedded worldlets"
+ ActiveWorld allMorphs do:
+ [:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]].
+
^ nil!
Item was changed:
----- 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' translatedNoop]!
- ['world']!
Item was changed:
----- 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@0) anyShapeFill reverse.
+ screenForm _ Form fromDisplay: (topLeft extent: outline extent).
- outline := poly shadowForm.
- topLeft := outline offset.
- exterior := (outline offset: 0@0) anyShapeFill reverse.
- screenForm := Form fromDisplay: (topLeft extent: outline extent).
screenForm eraseShape: exterior.
+ innerForm _ screenForm trimBordersOfColor: Color transparent.
+ ActiveHand showTemporaryCursor: nil.
- innerForm := screenForm trimBordersOfColor: Color transparent.
innerForm isAllWhite ifFalse:
[hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was changed:
----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
flapTab
+ "Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'"
+
| ww |
self isFlap ifFalse:[^nil].
+ ww _ self presenter associatedMorph ifNil: [ActiveWorld].
+ ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]!
- ww := self world ifNil: [World].
- ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]!
Item was changed:
----- 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>'])
+ , 'grid visible when gridding' translated!
- , 'show grid when gridding' translated!
Item was changed:
----- Method: PasteUpMorph>>installFlaps (in category 'world state') -----
installFlaps
"Get flaps installed within the bounds of the receiver"
+ | localFlapTabs |
Project current assureFlapIntegrity.
self addGlobalFlaps.
+ localFlapTabs := self localFlapTabs.
+ localFlapTabs do: [:each | each visible: false].
+
+ Preferences eToyFriendly ifTrue: [
+ ProgressInitiationException display: 'Building Viewers...' translated
+ during: [:bar |
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld.
+ bar value: i / self localFlapTabs size]].
+ ] ifFalse: [
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld]].
+
- self localFlapTabs do:
- [:aFlapTab | aFlapTab adaptToWorld].
self assureFlapTabsFitOnScreen.
self bringTopmostsToFront!
Item was changed:
----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') -----
presentCardAndStackMenu
"Put up a menu holding card/stack-related options."
| aMenu |
+ aMenu _ MenuMorph new defaultTarget: self.
- aMenu := MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
+ aMenu addTitle: 'card and stack' translated.
+ aMenu add: 'add new card' translated action: #insertCard.
+ aMenu add: 'delete this card' translated action: #deleteCard.
+ aMenu add: 'go to next card' translated action: #goToNextCardInStack.
+ aMenu add: 'go to previous card' translated action: #goToPreviousCardInStack.
- 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' translated action: #showForegroundObjects.
+ aMenu add: 'show background objects' translated action: #showBackgroundObjects.
+ aMenu add: 'show designations' translated action: #showDesignationsOfObjects.
+ aMenu add: 'explain designations' translated action: #explainDesignations.
- 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 changed:
----- Method: PasteUpMorph>>referencePool (in category 'objects from disk') -----
referencePool
^ self
valueOfProperty: #References
+ ifAbsentPut: [WeakValueDictionary new]
+ !
- ifAbsentPut: [OrderedCollection new]
-
- !
Item was changed:
----- 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 changed:
----- 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]!
- aPlayer startRunning; step; stopRunning].
-
- self allScriptors do:
- [:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
- !
Item was changed:
----- 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 stopSound.
+ aPlayer stopRunning].
- aPlayer stopRunning].
- self allScriptors do:
- [:aScript | aScript pauseIfTicking].
self world updateStatusForAllScriptEditors!
Item was changed:
----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') -----
triggerClosingScripts
"If the receiver has any scripts set to run on closing, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllClosingScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllClosingScripts]!
Item was changed:
----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') -----
triggerOpeningScripts
"If the receiver has any scripts set to run on opening, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllOpeningScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllOpeningScripts]!
Item was changed:
----- 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:
+ [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]!
- [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 changed:
----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
setTextColor: aColor
"Set the color of my text to the given color"
+ textMorph textColor: aColor!
- textMorph color: aColor!
Item was changed:
----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Polygon' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ 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.' translatedNoop!
- ^ 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 changed:
----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu 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."
+
- addCustomMenuItems: aMenu hand: aHandMorph
- | |
super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles.
+ vertices size > 2 ifTrue:
+ [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed].
+
+ aMenu addUpdating: #smoothPhrase target: self action: #toggleSmoothing.
+ aMenu addLine.
+ aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
+
+ self isOpen ifTrue:
+ [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]].!
- 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 changed:
----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
+
+ ^ Color black
+
+ "Until September 2007, this had long been...
^ Color
r: 0.0
g: 0.419
+ b: 0.935"!
- b: 0.935!
Item was changed:
----- Method: PolygonMorph>>fillStyle (in category 'visual properties') -----
fillStyle
+ "Answer the receiver's fillStyle. For an *open* polygon, we return the borderColor, provided it's a true color rather than something strange like the symbol #raised."
+ | aColor |
self isOpen
+ ifTrue:
+ [(aColor := self borderColor) isColor ifTrue: [^ aColor]]. "easy access to line color from halo -- di's old note"
+
+ ^ super fillStyle!
- ifTrue: [^ self borderColor "easy access to line color from halo"]
- ifFalse: [^ super fillStyle]!
Item was changed:
----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') -----
handlesShowingPhrase
+ "Answer a phrase characterizing whether handles are showing or not."
+
+ ^ (self showingHandles ifTrue: ['<yes>'] ifFalse: ['<no>']), ('show handles' translated)!
- ^ (self showingHandles
- ifTrue: ['hide handles']
- ifFalse: ['show handles']) translated!
Item was changed:
----- Method: PolygonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
+ "Handle a mouse-down event."
+ ^ (evt shiftPressed and: [(self hasProperty: #activateOnShift) not])
- ^ 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 changed:
----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') -----
openOrClosePhrase
+ "Answer a string indicating whether the receiver is open or closed."
+
+ ^ (closed ifTrue: ['<yes>'] ifFalse: ['<no>']), 'closed' translated!
- | 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 changed:
----- Method: PolygonMorph>>stepTime (in category 'testing') -----
stepTime
+ "Answer the desired time between steps in milliseconds."
+ ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [100]
+
+ "NB: in all currently known cases, polygons are not actually wrapped in TransformationMorphs, so the #topRendererOrSelf call above is probably redundant, but is retained for safety."!
- ^ 100!
Item was changed:
----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') -----
+ verticesAt: anInteger put: aPoint
+
+ self vertices at: anInteger put: aPoint asFloatPoint.
- verticesAt: ix put: newPoint
- vertices at: ix put: newPoint.
self computeBounds!
Item was changed:
----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') -----
allCurrentlyTickingScriptInstantiations
+ "Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking."
+
+ ^ Array streamContents:
+ [:aStream |
+ self allExtantPlayers do:
+ [:aPlayer | aPlayer instantiatedUserScriptsDo:
+ [:aScriptInstantiation |
+ aScriptInstantiation status == #ticking ifTrue:
+ [aStream nextPut: aScriptInstantiation]]]]!
- ^#()!
Item was changed:
----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') -----
+ browseAllScriptsTextually
+ "Open a method-list browser on all the scripts in the project"
+
+ | aList aMethodList |
+ self flushPlayerListCache. "Just to be certain we get everything"
+
+ (aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players' translated].
+ aMethodList _ OrderedCollection new.
+ aList do:
+ [:aPair | aPair first addMethodReferencesTo: aMethodList].
+ aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!' translated].
+
+ SystemNavigation new
+ browseMessageList: aMethodList
+ name: 'All scripts in this project'
+ autoSelect: nil
+
+ "
+ ActiveWorld presenter browseAllScriptsTextually
+ "!
- browseAllScriptsTextually!
Item was changed:
----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'ProjectView' translatedNoop!
- ^ 'ProjectView'!
Item was changed:
----- 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' translatedNoop
- label: 'load as project'
selector: #openFromDirectoryAndFileName:
+ description: 'open project from file' translatedNoop
+ buttonLabel: 'load' translatedNoop
- description: 'open project from file'
- buttonLabel: 'load'
)
argumentGetter: [ :fileList | fileList dirAndFileName]!
Item was changed:
----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
+ "Accept -- in a custom sense here -- a morph dropped on the receiver."
| 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 dropEnabled ifFalse:
+ [^ 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.
- 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 changed:
----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
dismissViaHalo
+ "The user clicked on the dismiss icon on the halo."
+
| choice |
+ project ifNil: [^ self delete]. "no current project"
+ choice := (PopUpMenu labelArray:{
+ 'yes - delete icon and remove the project' translated.
+ 'no - delete icon but keep the project' translated.
+ 'cancel - do not delete anything' translated.
+ }) startUpWithCaption: ('Do you really want to delete the
+ project named {1}
+ and all its contents?' translated format: {project name printString}).
+ choice = 1 ifTrue: [^ self expungeProject].
+ choice = 2 ifTrue: [^ self delete]!
- 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 changed:
----- 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' translated
- ^self inform: 'The project is not present and may not be renamed now'
].
self addProjectNameMorph launchMiniEditor: evt.!
Item was changed:
----- 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' translated]].
- 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 changed:
----- Method: ProjectViewMorph>>fontForName (in category 'drawing') -----
fontForName
+ ^(TextStyle default fontOfSize: 15) emphasized: 1
- | 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 changed:
----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver."
+
super initialize.
+ "currentBorderColor _ Color gray."
+ self addProjectNameMorphFiller.
+ self enableDragNDrop: true.
+ self isOpaque: true.
+ !
- "currentBorderColor := Color gray."
- self addProjectNameMorphFiller.!
Item was changed:
----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
+ "Answer if the receiver would accept a drop of a given morph."
+ "If drop-enabled not set, answer false"
+ (super wantsDroppedMorph: aMorph event: evt) ifFalse: [^ false].
+
+ "If project not present, not morphic, or not initialized, answer false"
+ self isTheRealProjectPresent ifFalse: [^ false].
+ project isMorphic ifFalse: [^ false].
+ project world viewBox ifNil: [^ false].
+
+ ^ true!
- self isTheRealProjectPresent ifFalse: [^false].
- project isMorphic ifFalse: [^false].
- project world viewBox ifNil: [^false]. "uninitialized"
- ^true!
Item was changed:
----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Rectangle' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'A rectangular shape, with border and fill style' translatedNoop!
- ^ self partName: 'Rectangle'
- categories: #('Graphics' 'Basic')
- documentation: 'A rectangular shape, with border and fill style'!
Item was changed:
----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') -----
roundRectPrototype
+ "Answer a prototypical RoundRect object for a parts bin."
+
^ self authoringPrototype useRoundedCorners
+ color: (Color r: 1.0 g: 0.3 b: 0.6);
- color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5);
borderWidth: 1;
setNameTo: 'RoundRect'!
Item was changed:
----- 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].
+ (self valueOfProperty: #withMenuButton) == false ifTrue: [^ nil].
+ menu _ MenuMorph new defaultTarget: model.
+ aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
- menu := MenuMorph new defaultTarget: model.
- aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
getMenuSelector numArgs = 1 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu.
- [aMenu := model perform: getMenuSelector with: menu.
aTitle ifNotNil: [aMenu addTitle: aTitle].
^ aMenu].
getMenuSelector numArgs = 2 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
- [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 changed:
----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Selection' translatedNoop!
- ^ 'Selection'!
Item was changed:
----- 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}.
+ #-.
+ {'distribute vertically' translated. #distributeVertically}.
+ {'distribute horizontally' translated. #distributeHorizontally}.
+ }
- }.
+
- self selectedItems size > 2
- ifTrue:[
- aMenu addList: {
- #-.
- {'distribute vertically' translated. #distributeVertically}.
- {'distribute horizontally' translated. #distributeHorizontally}.
- }.
- ].
!
Item was changed:
----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
+ selectedItems do: [:m | m dismissViaHalo].
-
super dismissViaHalo.
+ !
- selectedItems do: [:m | m dismissViaHalo]!
Item was changed:
----- Method: SelectionMorph>>extent: (in category 'geometry') -----
extent: newExtent
+ "Set the receiver's extent Extend or contract the receiver's selection to encompass morphs within the new extent."
super extent: newExtent.
+ self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])!
- self selectSubmorphsOf: self pasteUpMorph!
Item was changed:
----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: evt
+ "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
selectedItems isEmpty ifTrue:
["Hand just clicked down to draw out a new selection"
^ self extendByHand: evt hand].
+ dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
- 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)] fixTemps].
+ selectedItems _ nil.
+ self removeHalo.
+ self halo ifNotNil: [self halo visible: false].
+ self delete.
- (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
evt wasHandled: true!
Item was changed:
----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') -----
selectSubmorphsOf: aMorph
+ "Given the receiver's current bounds, select submorphs of the indicated pasteup morph that fall entirely within those bounds. If nobody is within the bounds, delete the receiver."
| newItems removals |
+ newItems _ aMorph submorphs select:
- newItems := aMorph submorphs select:
[:m | (bounds containsRect: m fullBounds)
and: [m~~self
and: [(m isKindOf: HaloMorph) not]]].
+ otherSelection ifNil: [^ selectedItems _ newItems].
- otherSelection ifNil: [^ selectedItems := newItems].
+ removals _ newItems intersection: itemsAlreadySelected.
- removals := newItems intersection: itemsAlreadySelected.
otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
+ selectedItems _ (newItems copyWithoutAll: removals).
+ selectedItems ifEmpty: [self delete]
- selectedItems := (newItems copyWithoutAll: removals).
!
Item was changed:
----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') -----
slideToTrash: evt
self delete.
+ "selectedItems do: [:m | m slideToTrash: evt]"!
- selectedItems do: [:m | m slideToTrash: evt]!
Item was changed:
----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
hasContentsInExplorer
+ ^self notEmpty!
- ^self isEmpty not!
Item was changed:
----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
^ self = SimpleButtonMorph
+ ifTrue: ['Button' translatedNoop]
- ifTrue: ['Button']
ifFalse: [^ super defaultNameStemForInstances]!
Item was changed:
----- 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 action selector' translated action: #setActionSelector.
aCustomMenu add: 'change arguments' translated action: #setArguments.
aCustomMenu add: 'change when to act' translated action: #setActWhen.
+ aCustomMenu add: 'set target' translated action: #sightTargets:.
+ target ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]].
- self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
!
Item was changed:
----- 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:
+ [target perform: actionSelector withArguments: arguments].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments]].
actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]!
Item was changed:
----- 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."
+ ^ super 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.
+ Feb 2007: It seems unlikely that Squeak Pages will be used in the OLPC image. Don't use this code. Consider removing all code that supports SqueakPages."
+ "
| bb thatPage um stem ind sqPg |
(actionSelector == #goToPageMorph:fromBookmark:) |
(actionSelector == #goToPageMorph:) ifFalse: [
+ ^ super objectForDataStream: refStrm]. 'normal case'.
- ^ super objectForDataStream: refStrm]. "normal case"
+ target url ifNil: ['Later force target book to get a url.'.
+ bb _ SimpleButtonMorph new. 'write out a dummy'.
- 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.
- (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.
- 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.
- 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'.
- 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
+ "!
- ^ um!
Item was changed:
----- Method: SimpleButtonMorph>>updateVisualState: (in category 'visual properties') -----
updateVisualState: evt
oldColor ifNotNil: [
self color:
((self containsPoint: evt cursorPoint)
+ ifTrue: [oldColor mixed: 0.5 with: Color white]
- ifTrue: [oldColor mixed: 1/2 with: Color white]
ifFalse: [oldColor])]
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ self setProperty: #autoExpand toValue: false.
self
on: #mouseMove
send: #mouseStillDown:onItem:
to: self!
Item was changed:
----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Sketch' translatedNoop!
- ^ 'Sketch'!
Item was changed:
----- Method: SketchMorph>>addToggleItemsToHaloMenu: (in category 'menus') -----
addToggleItemsToHaloMenu: aCustomMenu
+ "Add toggle-items to the halo menu"
+
- "Add toggle-items to the halo menu"
super addToggleItemsToHaloMenu: aCustomMenu.
+ (Smalltalk includesKey: #B3DRenderEngine) ifTrue: [
+ aCustomMenu addUpdating: #useInterpolationString target: self action: #toggleInterpolation.
+ ].
+ !
- Preferences noviceMode
- ifFalse: [""aCustomMenu
- addUpdating: #useInterpolationString
- target: self
- action: #toggleInterpolation]!
Item was changed:
----- Method: SketchMorph>>collapse (in category 'menus') -----
collapse
+ "Replace the receiver with a collapsed rendition of itself."
-
- | priorPosition w collapsedVersion a |
+ | w collapsedVersion a ht tab |
+
+ (w _ self world) ifNil: [^self].
+ collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
- (w := self world) ifNil: [^self].
- collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph.
collapsedVersion setProperty: #uncollapsedMorph toValue: self.
collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
+
+ collapsedVersion setBalloonText: ('A collapsed version of {1}. Click to open it back up.' translated format: {self externalName}).
+
- collapsedVersion setBalloonText: 'A collapsed version of ',self name.
-
self delete.
w addMorphFront: (
+ a _ AlignmentMorph newRow
- a := AlignmentMorph newRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 4;
borderColor: Color white;
+ addMorph: collapsedVersion;
+ yourself).
+ a setNameTo: self externalName.
+ ht := (tab := ActiveWorld findA: SugarNavTab)
+ ifNotNil:
+ [tab height]
+ ifNil:
+ [80].
+ a position: 0@ht.
+
- addMorph: collapsedVersion
- ).
collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+ (self valueOfProperty: #collapsedPosition) ifNotNilDo:
+ [:priorPosition |
+ a position: priorPosition]!
- (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil])
- ifNotNil:
- [a position: priorPosition].
- !
Item was changed:
----- 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 x = 0 or: [newExtent y = 0]) ifTrue: [ ^self ].
- newExtent isZero ifTrue: [ ^self ].
self extent = newExtent ifTrue:[^self].
self scalePoint: newExtent asFloatPoint / (originalForm extent max: 1@1).
self layoutChanged.
!
Item was changed:
----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') -----
flipHorizontal
+ | r |
+ r _ self rotationCenter.
+ self left: self left - (1.0 - (2 * r x) * self width).
+ self form: (self form flipBy: #horizontal centerAt: self form center).
+ self rotationCenter: (1 - r x) @ (r y).!
- self form: (self form flipBy: #horizontal centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>flipVertical (in category 'e-toy support') -----
flipVertical
+ | r |
+ r _ self rotationCenter.
+ self top: self top - (1.0 - (2 * r y) * self height).
+ self form: (self form flipBy: #vertical centerAt: self form center).
+ self rotationCenter: r x @ (1 - r y).!
- self form: (self form flipBy: #vertical centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>initializeWith: (in category 'initialization') -----
initializeWith: aForm
super initialize.
+ originalForm _ aForm.
+ rotationStyle _ #normal. "styles: #normal, #leftRight, #upDown, or #none"
+ scalePoint _ 1.0(a)1.0.
+ framesToDwell _ 1.
+ rotatedForm _ originalForm. "cached rotation of originalForm"
- originalForm := aForm.
- self rotationCenter: 0.5(a)0.5. "relative to the top-left corner of the Form"
- rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none"
- scalePoint := 1.0(a)1.0.
- framesToDwell := 1.
- rotatedForm := originalForm. "cached rotation of originalForm"
self extent: originalForm extent.
!
Item was changed:
----- 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
+ Because my rendering code flips the form (see generateRotatedForm) we 'pre-flip' it here to preserve the same visual appearance.
+ "
- #none -- do not rotate"
+ | wasFlippedX wasFlippedY isFlippedX isFlippedY |
+ wasFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ wasFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ rotationStyle _ aSymbol.
+
+ isFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ isFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ wasFlippedX == isFlippedX
+ ifFalse: [self form: (self form flipBy: #horizontal centerAt: self form center)].
+ wasFlippedY == isFlippedY
+ ifFalse: [self form: (self form flipBy: #vertical centerAt: self form center)].
+
- rotationStyle := aSymbol.
self layoutChanged.
!
Item was changed:
----- Method: Slider>>sliderThickness (in category 'geometry') -----
sliderThickness
+ "^ 7"
+
+ | w |
+ w _ bounds isWide
+ ifTrue: [super height]
+ ifFalse: [super width].
+
+ ^ (w // 32) max: 16.
+ !
- ^ 7!
Item was changed:
----- 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: [FormDictionary at: #Cat]].
+ ^ FormDictionary at: #Cat!
- [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
- ^ nil!
Item was changed:
----- 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.
+ aCustomMenu addUpdating: #usePangoString target: self action: #toggleUsePango.
!
Item was changed:
----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
addOptionalHandlesTo: aHalo box: box
+ "eventually, add more handles for font..."
+
self flag: #deferred.
+ ^ super addOptionalHandlesTo: aHalo box: box
"Eventually...
self addFontHandlesTo: aHalo box: box"!
Item was changed:
----- 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 projectParameterAt: #substitutedFont).
+ (substituteFont notNil and: [self font == substituteFont])
- substituteFont := aProject projectParameters at:
- #substitutedFont ifAbsent: [#none].
- (substituteFont ~~ #none and: [self font == substituteFont])
ifTrue: [ self fitContents ].
^ super fixUponLoad: aProject seg: anImageSegment!
Item was changed:
----- Method: StringMorph>>font: (in category 'printing') -----
font: aFont
"Set the font my text will use. The emphasis remains unchanged."
+ aFont = font ifTrue: [^ self].
+ font _ aFont.
- font := aFont.
^ self font: font emphasis: emphasis!
Item was changed:
----- Method: StringMorphEditor>>initialize (in category 'display') -----
initialize
"Initialize the receiver. Give it a white background"
super initialize.
self backgroundColor: Color white.
+ self textColor: Color red.!
- self color: Color red!
Item was changed:
----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'TrueType banner' translatedNoop
+ categories: #()
+ documentation: 'A short text in a beautiful font. Use the resize handle to change size.' translatedNoop!
- ^ self partName: 'TrueType banner'
- categories: #('Demo')
- documentation: 'A short text in a beautiful font. Use the resize handle to change size.'!
Item was changed:
----- 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' translatedNoop. 'A scrolling data field which will have a different value on every card of the background' translatedNoop}
- 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 changed:
----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') -----
borderedPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t fontName: 'BitstreamVeraSans' pointSize: 24.
t autoFit: false; extent: 250@100.
+ t borderWidth: 1; margins: 4@0; backgroundColor: Color white.
- t borderWidth: 1; margins: 4@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 changed:
----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Text' translatedNoop!
- ^ 'Text'!
Item was changed:
----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') -----
fancyPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t autoFit: false; extent: 150@75.
t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?"
"fancy font, shadow, rounded"
+ t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; fillStyle: Color lightBrown.
- 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 changed:
----- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- 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' translatedNoop. 'A piece of text that will occur on every card of the background' translatedNoop}
- 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' translatedNoop. 'A data field which will have a different value on every card of the background' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you wish' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish')
forFlapNamed: 'Stack Tools'.
+ cl registerQuad: {#TextMorph . #fancyPrototype. 'Fancy Text' translatedNoop. 'A text field with a rounded shadowed border, with a fancy font.' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
forFlapNamed: 'Supplies'.]!
Item was changed:
----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+ (self backgroundColor isNil or: [self backgroundColor asColor isTranslucent])
- (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 changed:
----- Method: TextMorph>>backgroundColor (in category 'accessing') -----
backgroundColor
+ ^ self fillStyle.
+ !
- ^ backgroundColor!
Item was changed:
----- Method: TextMorph>>backgroundColor: (in category 'accessing') -----
backgroundColor: newColor
+ self fillStyle: newColor.
+ !
- backgroundColor := newColor.
- self changed!
Item was changed:
----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
beAllFont: aFont
+ textStyle _ TextStyle fontArray: (Array with: aFont).
+ text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)].
- textStyle := TextStyle fontArray: (Array with: aFont).
self releaseCachedState; changed!
Item was changed:
----- Method: TextMorph>>defaultLineHeight (in category 'geometry') -----
defaultLineHeight
+ ^ ( textStyle fontAt: textStyle defaultFontIndex) pointSize!
- ^ textStyle lineGrid!
Item was changed:
----- 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 wid |
- | newExtent para cBounds lastOfLines heightOfLast |
self isAutoFit
ifTrue:
+ [wid _ (text notNil and: [text size > 2]) ifTrue: [5] ifFalse: [40].
+ newExtent := (self paragraph extent max: wid @ ( self defaultLineHeight)) + (0 @ 2).
- [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 changed:
----- Method: TextMorph>>insertCharacters: (in category 'scripting access') -----
+ insertCharacters: aString
- insertCharacters: aSource
"Insert the characters from the given source at my current cursor position"
+ | aLoc aText attributes |
- | aLoc |
aLoc := self cursor max: 1.
+ aText := aLoc > text size
+ ifTrue: [aString asText]
+ ifFalse: [
+ attributes := (text attributesAt: aLoc)
+ select: [:attr | attr mayBeExtended].
+ Text string: aString attributes: attributes].
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aText displaying: true.
- paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
self updateFromParagraph !
Item was changed:
----- 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].
- [paragraph := nil].
container ifNotNil:
+ [container isMorph ifTrue: [container releaseCachedState]]!
- [container releaseCachedState]!
Item was changed:
----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') -----
setAllButFirstCharacter: source
"Set all but the first char of the receiver to the source"
+ | chars |
+ (chars _ self getCharacters) isEmpty
- | aChar chars |
- aChar := source asCharacter.
- (chars := self getCharacters) isEmpty
ifTrue: [self newContents: 'ยท' , source asString]
+ ifFalse: [self newContents: (String
- ifFalse: [chars first = aChar
- ifFalse: [""
- self
- newContents: (String
streamContents: [:aStream |
aStream nextPut: chars first.
+ aStream nextPutAll: source])]!
- aStream nextPutAll: source])]] !
Item was changed:
----- Method: TextMorph>>textColor: (in category 'accessing') -----
textColor: aColor
+ self editor selectFrom: 1 to: 0.
+ self selectionColor: aColor.
- color = aColor ifTrue: [^ self].
- color := aColor.
- self changed.
!
Item was changed:
----- Method: TheWorldMenu>>remoteMenu (in category 'construction') -----
remoteMenu
"Build the Telemorphic menu for the world."
+ ^self fillIn: (self menu: 'Telemorphic' translatedNoop) from: {
+ { 'local host address' translatedNoop. { #myWorld . #reportLocalAddress } }.
+ { 'connect remote user' translatedNoop. { #myWorld . #connectRemoteUser } }.
+ { 'disconnect remote user' translatedNoop. { #myWorld . #disconnectRemoteUser } }.
+ { 'disconnect all remote users' translatedNoop. { #myWorld . #disconnectAllRemoteUsers } }.
- ^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 changed:
----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') -----
windowsMenu
"Build the windows menu for the world."
+ ^ self fillIn: (self menu: 'windows' translatedNoop) from: {
+ { 'find window' translatedNoop. { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' translatedNoop}.
- ^ 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...' translatedNoop. { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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...' translatedNoop. { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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.' translatedNoop}.
- tile: new windows positioned so that they do not overlap others, if possible.'}.
nil.
+ { 'collapse all windows' translatedNoop. { #myWorld . #collapseAllWindows }. 'Reduce all open windows to collapsed forms that only show titles.' translatedNoop}.
+ { 'collapse all objects' translatedNoop. { #myWorld . #collapseAllWindowsAndNonWindows }. 'Reduce all open windows and all other objects on the desktop to labeled tabs' translatedNoop}.
+ { 'expand all' translatedNoop. { #myWorld . #expandAllCollapsedObjects }. 'Expand all collapsed windows and other collapsed objects back to their expanded forms.' translatedNoop}.
+
+ { 'close top window (w)' translatedNoop. { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.' translatedNoop}.
+ { 'send top window to back (\)' translatedNoop. { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.' translatedNoop}.
+ { 'move windows onscreen' translatedNoop. { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen' translatedNoop}.
- { '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' translatedNoop. { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.' translatedNoop}.
+ { 'delete non-windows' translatedNoop. { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.' translatedNoop}.
+ { 'delete both of the above' translatedNoop. { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' translatedNoop}.
- { '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 changed:
----- 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."
+ | args |
(target notNil and: [actionSelector notNil])
ifTrue:
+ [args := actionSelector numArgs > arguments size
+ ifTrue:
+ [arguments copyWith: ActiveEvent]
+ ifFalse:
+ [arguments].
+ Cursor normal
+ showWhile: [target perform: actionSelector withArguments: args].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments].
target isMorph ifTrue: [target changed]]!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| now dt |
- self state: #pressed.
actWhen == #buttonDown
+ ifTrue: [self doButtonAction].
+ actWhen == #buttonUp
+ ifTrue: [self state: #pressed].
+ actWhen == #whilePressed
+ ifTrue:
+ [self state: #pressed.
+ now _ Time millisecondClockValue.
- 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"
+ "NOTE: this delay is temporary disabled because it makes event reaction delay,
+ e.g. the action is not stopped even if you release the button... - Takashi"
+ [dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
+ self mouseStillDown: evt].
+ super mouseDown: evt!
- dt := Time millisecondClockValue - now max: 0. "Time it took to do"
- dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
- self mouseStillDown: evt.!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ (#(#buttonUp #whilePressed ) includes: actWhen)
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #pressed]
+ ifFalse: [self state: #off]].
+ super mouseMove: evt!
- 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 changed:
----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
- mouseUp: evt
"Allow on:send:to: to set the response to events other than actWhen"
+ actWhen == #buttonDown
+ ifTrue: [super mouseUp: evt].
+ actWhen == #buttonUp
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #on.
+ self doButtonAction: evt.
+ super mouseUp: evt]
+ ifFalse: [self state: #off.
+ target
+ ifNotNil: ["Allow owner to keep it selected for radio
+ buttons"
+ target mouseUpBalk: evt]]].
+ actWhen == #whilePressed
+ ifTrue: [self state: #off.
+ super mouseUp: evt]!
- 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 changed:
----- 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: [1]
- ifTrue: [ 2]
ifFalse: [1]!
Item was changed:
----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') -----
fitContents
+ | newExtent |
+ newExtent := self measureContents.
+ newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.
- | 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 changed:
----- Method: UpdatingStringMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver to have default values in its instance variables."
- "Initialie the receiver to have default values in its instance
- variables "
super initialize.
""
+ format _ #default.
- format := #default.
"formats: #string, #default"
+ target _ getSelector _ putSelector _ nil.
+ floatPrecision _ 1.
+ growable _ true.
+ stepTime _ nil.
+ autoAcceptOnFocusLoss _ true.
+ minimumWidth _ 8.
+ maximumWidth _ 366!
- target := getSelector := putSelector := nil.
- floatPrecision := 1.
- growable := true.
- stepTime := 50.
- autoAcceptOnFocusLoss := true.
- minimumWidth := 8.
- maximumWidth := 300!
Item was changed:
----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') -----
readFromTarget
"Update my readout from my target"
+ | v ret places |
- | v ret |
(target isNil or: [getSelector isNil]) ifTrue: [^contents].
+ ret _ self checkTarget.
- ret := self checkTarget.
ret ifFalse: [^ '0'].
+ ((target isMorph) or:[target isPlayerLike]) ifTrue:[
+ places _ target decimalPlacesForGetter: getSelector.
+ (places ~= nil and: [ places ~= (self valueOfProperty: #decimalPlaces ifAbsent: [0])]) ifTrue: [ self decimalPlaces: places ]].
v := target perform: getSelector. "scriptPerformer"
(v isKindOf: Text) ifTrue: [v := v asString].
^self acceptValueFromTarget: v!
Item was changed:
----- 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 := MenuMorph new.
aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
+ 0 to: 10 do:
- 0 to: 5 do:
[:places |
aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
aMenu popUpInWorld!
Item was changed:
----- Method: UpdatingStringMorph>>stepTime (in category 'testing') -----
stepTime
+ ^ stepTime ifNil: [200]
- ^ stepTime ifNil: [50]
!
Item was changed:
----- 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.
+ self setProperty: #decimalPlaces toValue: ((self valueOfProperty: #decimalPlaces ifAbsent: [0]) veryDeepCopyWith: 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.
!
1
0
Tim Felgentreff uploaded a new version of EToys to project The Trunk:
http://source.squeak.org/trunk/EToys-tfel.228.mcz
==================== Summary ====================
Name: EToys-tfel.228
Author: tfel
Time: 31 August 2016, 8:49:05.051755 pm
UUID: f9d5b452-9e2a-7045-b2ab-399366c623f9
Ancestors: EToys-tfel.227
apply fix from jl to skip drawing turtles if the semaphore is locked
=============== Diff against EToys-tfel.227 ===============
Item was changed:
----- Method: KedamaMorph>>drawTurtlesOnForm: (in category 'drawing') -----
drawTurtlesOnForm: aForm
turtlesToDisplay do: [:exampler |
(self isVisible: exampler) ifTrue: [
turtlesDictSemaphore critical: [
exampler turtles drawOn: aForm.
+ ] ifLocked: []
- ].
].
].
!
1
0
Tim Felgentreff uploaded a new version of EToys to project The Trunk:
http://source.squeak.org/trunk/EToys-tfel.228.mcz
==================== Summary ====================
Name: EToys-tfel.228
Author: tfel
Time: 31 August 2016, 8:49:05.051755 pm
UUID: f9d5b452-9e2a-7045-b2ab-399366c623f9
Ancestors: EToys-tfel.227
apply fix from jl to skip drawing turtles if the semaphore is locked
=============== Diff against EToys-tfel.227 ===============
Item was changed:
----- Method: KedamaMorph>>drawTurtlesOnForm: (in category 'drawing') -----
drawTurtlesOnForm: aForm
turtlesToDisplay do: [:exampler |
(self isVisible: exampler) ifTrue: [
turtlesDictSemaphore critical: [
exampler turtles drawOn: aForm.
+ ] ifLocked: []
- ].
].
].
!
1
0
Tim Felgentreff uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-tfel.1249.mcz
==================== Summary ====================
Name: Morphic-tfel.1249
Author: tfel
Time: 10 August 2016, 3:22:00.866665 pm
UUID: 49e9c531-0bfc-b345-b72d-4dd84f195f0b
Ancestors: Morphic-tfel.1248
merge project export code from squeakland, guard it so we don't depend on etoys or siss
=============== Diff against Morphic-mt.1246 ===============
Item was changed:
----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
supplementaryPartsDescriptions
"Extra items for parts bins"
^ {DescriptionForPartsBin
+ formalName: 'Circle' translatedNoop
+ categoryList: {'Graphics' translatedNoop}
+ documentation: 'A circular shape' translatedNoop
- formalName: 'Circle1'
- categoryList: #('Graphics')
- documentation: 'A circular shape'
globalReceiverSymbol: #CircleMorph
nativitySelector: #newStandAlone.
+ DescriptionForPartsBin
+ formalName: 'Pin' translatedNoop
+ categoryList: {'Connectors' translatedNoop}
+ documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop
- "DescriptionForPartsBin
- formalName: 'Pin'
- categoryList: #('Connectors')
- documentation: 'An attachment point for Connectors that you can embed in another Morph.'
globalReceiverSymbol: #NCPinMorph
+ nativitySelector: #newPin.
- nativitySelector: #newPin."
}!
Item was changed:
SketchMorph subclass: #ColorPickerMorph
+ instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency noChart'
+ classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransparentBox TransText'
- 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 changed:
----- 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 @ 31. "<<<< the form was changed a bit??"
- 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 changed:
----- 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 insetBy: 2) fillColor: feedbackColor.
- originalForm fill: FeedbackBox fillColor: feedbackColor.
self form: originalForm.
+ selectedColor _ aColor.
- selectedColor := aColor.
updateContinuously ifTrue: [self updateTargetColor].
self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).!
Item was changed:
----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Ellipse' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'An elliptical or circular shape' translatedNoop!
- ^ self partName: 'Ellipse'
- categories: #('Graphics' 'Basic')
- documentation: 'An elliptical or circular shape'!
Item was changed:
----- Method: HaloMorph>>addDupHandle: (in category 'handles') -----
addDupHandle: haloSpec
"Add the halo that offers duplication, or, when shift is down, make-sibling"
+ | aSelector |
+ aSelector := innerTarget couldMakeSibling
+ ifTrue:
+ [#doDupOrMakeSibling:with:]
+ ifFalse:
+ [#doDup:with:].
- self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self
+ self addHandle: haloSpec on: #mouseDown send: aSelector to: self
+
!
Item was changed:
----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') -----
addHandlesForWorldHalos
"Add handles for world halos, like the man said"
| box w |
+ w _ self world ifNil:[target world].
- w := self world ifNil:[target world].
self removeAllMorphs. "remove old handles, if any"
self bounds: target bounds.
+ box _ w bounds insetBy: self handleSize // 2.
- box := w bounds insetBy: 9.
target addWorldHandlesTo: self box: box.
Preferences uniqueNamesInHalos ifTrue:
[innerTarget assureExternalName].
self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
+ growingOrRotating _ false.
- growingOrRotating := false.
self layoutChanged.
self changed.
!
Item was changed:
----- Method: HaloMorph>>addViewingHandle: (in category 'handles') -----
addViewingHandle: haloSpec
+ "If appropriate, add a special Viewing halo handle to the receiver. On 26 Sept 07, we decided to eliminate this item from the UI, so the code of is method is now commented out...
- "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 changed:
----- Method: HaloMorph>>basicBox (in category 'private') -----
basicBox
| aBox minSide anExtent w |
+ minSide _ 4 * self handleSize.
+ anExtent _ ((self width + self handleSize + 8) max: minSide) @
- 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].
- aBox := Rectangle center: self center extent: anExtent.
- w := self world ifNil:[target outermostWorldMorph].
^ w
ifNil:
[aBox]
ifNotNil:
+ [aBox intersect: (w viewBox insetBy: self handleSize // 2)]
- [aBox intersect: (w viewBox insetBy: 8@8)]
!
Item was changed:
----- Method: HaloMorph>>doDirection:with: (in category 'private') -----
doDirection: anEvent with: directionHandle
+ "The mouse went down on the forward-direction halo handle; respond appropriately."
+
anEvent hand obtainHalo: self.
+ anEvent shiftPressed
+ ifTrue:
+ [directionArrowAnchor _ (target point: target referencePosition in: self world) rounded.
+ self positionDirectionShaft: directionHandle.
+ self removeAllHandlesBut: directionHandle.
+ directionHandle setProperty: #trackDirectionArrow toValue: true]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: directionHandle]!
- self removeAllHandlesBut: directionHandle!
Item was changed:
----- Method: HaloMorph>>handleSize (in category 'private') -----
handleSize
^ Preferences biggerHandles
+ ifTrue: [30]
- ifTrue: [20]
ifFalse: [16]!
Item was changed:
----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') -----
prepareToTrackCenterOfRotation: evt with: rotationHandle
+ "The mouse went down on the center of rotation."
+
evt hand obtainHalo: self.
+ evt shiftPressed
+ ifTrue:
+ [self removeAllHandlesBut: rotationHandle.
+ rotationHandle setProperty: #trackCenterOfRotation toValue: true.
+ evt hand showTemporaryCursor: Cursor blank]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: rotationHandle]!
- evt shiftPressed ifTrue:[
- self removeAllHandlesBut: rotationHandle.
- ] ifFalse:[
- rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
- self startDrag: evt with: rotationHandle
- ].
- evt hand showTemporaryCursor: Cursor blank!
Item was changed:
----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') -----
setCenterOfRotation: evt with: rotationHandle
| localPt |
evt hand obtainHalo: self.
evt hand showTemporaryCursor: nil.
+ (rotationHandle hasProperty: #trackCenterOfRotation) ifTrue:
+ [localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
+ innerTarget setRotationCenterFrom: localPt].
+
+ rotationHandle removeProperty: #trackCenterOfRotation.
+ self endInteraction!
- (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
- localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
- innerTarget setRotationCenterFrom: localPt.
- ].
- rotationHandle removeProperty: #dragByCenterOfRotation.
- self endInteraction
- !
Item was changed:
----- 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"
+ (directionHandle hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ target setDirectionFrom: directionHandle center.
+ directionHandle removeProperty: #trackDirectionArrow.
+ self endInteraction]!
- anEvent hand obtainHalo: self.
- target setDirectionFrom: directionHandle center.
- self endInteraction!
Item was changed:
----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') -----
trackCenterOfRotation: anEvent with: rotationHandle
(rotationHandle hasProperty: #dragByCenterOfRotation)
ifTrue:[^self doDrag: anEvent with: rotationHandle].
+ (rotationHandle hasProperty: #trackCenterOfRotation)
+ ifTrue:
+ [anEvent hand obtainHalo: self.
+ rotationHandle center: anEvent cursorPoint]!
- anEvent hand obtainHalo: self.
- rotationHandle center: anEvent cursorPoint.!
Item was changed:
----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') -----
trackDirectionArrow: anEvent with: shaft
+ (shaft hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
+ self layoutChanged]!
- anEvent hand obtainHalo: self.
- shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
- self layoutChanged!
Item was changed:
----- Method: HandleMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self extent: 16 @ 16.
- self extent: 8 @ 8.
!
Item was changed:
----- Method: IconicButton>>stationarySetup (in category 'initialization') -----
stationarySetup
+ "Set up event handlers for mouse actions. Should be spelled stationery..."
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.
+
+ self on: #click send: #launchPartFromClick to: self!
- self on: #mouseUp send: #borderThick to: self.!
Item was changed:
----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Image' translatedNoop
+ categories: #()
+ documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.' translatedNoop!
- ^ 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 changed:
----- 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' translatedNoop. 'A non-editable picture of something' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Joystick' translatedNoop
+ categories: {'Basic' translatedNoop}
+ documentation: 'A joystick-like control' translatedNoop!
- ^ self partName: 'Joystick'
- categories: #('Useful')
- documentation: 'A joystick-like control'!
Item was changed:
----- 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' translatedNoop. 'A joystick-like control' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Scripting'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ "Answer a description for the parts bin."
+
+ ^ self partName: 'Line' translatedNoop
+ categories: {'Graphics' translatedNoop}
+ documentation: 'A straight line. Shift-click to get handles and move the ends.' translatedNoop!
- ^ self partName: 'Line'
- categories: #('Graphics' 'Basic')
- documentation: 'A straight line. Shift-click to get handles and move the ends.'!
Item was changed:
----- 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.
- ActiveWorld addMorph: self centeredNear: aPoint.
self world displayWorld. "show myself"
+ aBlock value]
+ ensure: [self delete]!
- aBlock value.
- self delete!
Item was changed:
----- Method: MenuIcons class>>iconForMenuItem: (in category 'menu decoration') -----
iconForMenuItem: anItem
+ "Answer the icon (or nil) corresponding to a given menu item."
- "Answer the icon (or nil) corresponding to the (translated) string."
+ | aKey |
+ aKey _ (anItem selector == #undoOrRedoCommand)
+ ifTrue:
+ ['undo (z)' translated] "Actual wording changes dynamically"
+ ifFalse:
+ [anItem contents asString].
+ ^ TranslatedIcons at: aKey asLowercase ifAbsent: [nil]!
- ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]!
Item was changed:
----- Method: MenuMorph>>delete (in category 'initialization') -----
delete
+ "Delete the receiver."
+
+ activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]].
+ self isFlexed ifTrue: [^ owner delete].
+ ^ super delete!
- activeSubMenu ifNotNil:[activeSubMenu delete].
- ^super delete!
Item was changed:
----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') -----
serviceLoadMorphFromFile
"Answer a service for loading a .morph file"
^ SimpleServiceEntry
provider: self
+ label: 'load as morph' translatedNoop
- label: 'load as morph'
selector: #fromFileName:
+ description: 'load as morph' translatedNoop
+ buttonLabel: 'load' translatedNoop!
- description: 'load as morph'
- buttonLabel: 'load'!
Item was changed:
----- 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 w |
+ menu _ MenuMorph new defaultTarget: self.
+ w _ self world.
+ self potentialEmbeddingTargets reverseDo: [:m |
+ menu add: (m == w ifTrue: ['desktop' translated] ifFalse: [m knownName ifNil:[m class name asString]]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}.
+ m == self topRendererOrSelf owner ifTrue:
+ [menu lastItem color: Color red]].
+ aMenu ifNotNil:
+ [menu submorphCount > 0
+ ifTrue:[aMenu add:'embed into' translated subMenu: 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 changed:
----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') -----
addFlexShell
"Wrap a rotating and scaling shell around this morph."
+ | oldHalo flexMorph myWorld anIndex morphOwner |
- | oldHalo flexMorph myWorld anIndex |
myWorld := self world.
+ oldHalo:= self halo.
+ self owner ifNotNil:[ morphOwner := self owner]
+ ifNil:[morphOwner := self currentWorld].
+
+ anIndex := morphOwner submorphIndexOf: self.
+ morphOwner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self)
- 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 changed:
----- Method: Morph>>addHaloActionsTo: (in category 'menus') -----
addHaloActionsTo: aMenu
"Add items to aMenu representing actions requestable via halo"
| subMenu |
+ subMenu _ MenuMorph new defaultTarget: self.
- 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 add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles.
subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.
+ subMenu add: 'tile representing this object' translated target: self action: #tearOffTile.
- 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 changed:
----- 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 notNil and: [aNumber <= submorphs size])
- (aNumber <= submorphs size)
ifTrue:
[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
ifFalse:
+ [self addMorphBack: aMorph]!
- [self addMorphBack: aMorph]
- !
Item was changed:
----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') -----
chooseNewGraphicCoexisting: aBoolean
"Allow the user to choose a different form for her form-based morph"
+
| replacee aGraphicalMenu |
+ self isInWorld ifFalse: "menu must have persisted for a not-in-world object."
+ [aGraphicalMenu := ActiveWorld submorphThat:
+ [:m | (m isKindOf: GraphicalMenu) and: [m target == self]]
+ ifNone:
+ [^ self].
+ ^ aGraphicalMenu show; flashBounds].
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 changed:
----- Method: Morph>>couldMakeSibling (in category 'testing') -----
couldMakeSibling
"Answer whether it is appropriate to ask the receiver to make a sibling"
+ ^ self isWorldMorph not!
- ^ true!
Item was changed:
----- Method: Morph>>goBehind (in category 'submorphs-add/remove') -----
goBehind
+ "Move the receiver to bottom z-order."
+ | topRend |
+ topRend := self topRendererOrSelf.
+ topRend owner ifNotNilDo:
+ [:own | own addMorphNearBack: topRend]
- owner addMorphNearBack: self.
!
Item was changed:
----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') -----
invokeMetaMenu: evt
+ "Put up the 'meta' menu, invoked via control-click, unless eToyFriendly is true."
+
| menu |
+ Preferences eToyFriendly ifTrue: [^ self].
+
+ menu _ self buildMetaMenu: evt.
- menu := self buildMetaMenu: evt.
menu addTitle: self externalName.
+ menu popUpEvent: evt in: self world!
- self world ifNotNil: [
- menu popUpEvent: evt in: self world
- ]!
Item was changed:
----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') -----
obtrudesBeyondContainer
"Answer whether the receiver obtrudes beyond the bounds of its container"
+ | top formerOwner |
- | top |
top := self topRendererOrSelf.
+ top owner ifNil: [^ false].
+ ^ top owner isHandMorph
+ ifTrue:
+ [((formerOwner := top formerOwner) notNil and: [formerOwner isInWorld])
+ ifFalse:
+ [false]
+ ifTrue:
+ [(formerOwner boundsInWorld containsRect: top boundsInWorld) not]]
+ ifFalse:
+ [(top owner bounds containsRect: top bounds) not]!
- (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
- ^(top owner bounds containsRect: top bounds) not!
Item was changed:
----- Method: Morph>>on:send:to: (in category 'event handling') -----
on: eventName send: selector to: recipient
+ "When the given event occurs, send the given selector to the given recipient. If the given selector is nil, rescind any earlier handling for the given event type,"
+
+ self eventHandler ifNil:
+ [selector ifNil: [^ self]. "Don't pointlessly create an event handler!!"
+ self eventHandler: EventHandler new].
- self eventHandler ifNil: [self eventHandler: EventHandler new].
self eventHandler on: eventName send: selector to: recipient!
Item was changed:
----- Method: Morph>>openViewerForArgument (in category 'player viewer') -----
openViewerForArgument
+ Cursor wait
+ showWhile: [self presenter viewMorph: self]!
- "Open up a viewer for a player associated with the morph in question. "
- self presenter viewMorph: self!
Item was changed:
----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') -----
overlapsShadowForm: itsShadow bounds: itsBounds
"Answer true if itsShadow and my shadow overlap at all"
+ | overlapExtent overlap myRect myShadow goalRect goalShadow bb |
+ overlap _ self fullBounds intersect: itsBounds.
+ overlapExtent _ overlap extent.
- | andForm overlapExtent |
- overlapExtent := (itsBounds intersect: self fullBounds) extent.
overlapExtent > (0 @ 0)
ifFalse: [^ false].
+ myRect := overlap translateBy: 0 @ 0 - self topLeft.
+ myShadow := (self imageForm contentsOfArea: myRect) stencil.
+ goalRect := overlap translateBy: 0 @ 0 - itsBounds topLeft.
+ goalShadow := (itsShadow contentsOfArea: goalRect) stencil.
+
+ "compute a pixel-by-pixel AND of the two stencils. Result will be black
+ (pixel value = 1) where black parts of the stencils overlap"
+ bb := BitBlt toForm: myShadow.
+ bb
+ copyForm: goalShadow
+ to: 0 @ 0
+ rule: Form and.
+
+ ^(bb destForm tallyPixelValues second) > 0 !
- 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 changed:
----- Method: Morph>>roundUpStrays (in category 'miscellaneous') -----
roundUpStrays
+ "Bring submorphs of playfieldlike structures in the receiver's interior back within view."
+
+ self submorphsDo:
+ [:m | m isPlayfieldLike ifTrue: [m roundUpStrays]]!
- self submorphs
- do: [:each | each roundUpStrays]!
Item was changed:
----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
slideBackToFormerSituation: evt
+ "A drop of the receiver having been rejected, slide it back to where it came from, if possible."
+
| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
formerOwner := self formerOwner.
formerPosition := self formerPosition.
+ (aWorld := evt hand world) ifNil: [^ self delete]. "Likely a moribund hand from an EventRecorder playback."
+
- 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.
+ "The OLPC Virtual Screen wouldn't notice the last update here."
+ Display forceToScreen: (endPoint extent: slideForm extent).
formerOwner addMorph: self.
self position: formerPosition.
self justDroppedInto: formerOwner event: evt!
Item was changed:
----- Method: Morph>>useGradientFill (in category 'visual properties') -----
useGradientFill
"Make receiver use a solid fill style (e.g., a simple color)"
+
+ | fill color1 color2 fil |
+ ((fil := self fillStyle) notNil and: [fil isSymbol not] and: [fil isGradientFill]) ifTrue:[^self]. "Already done"
+ color1 _ self color asColor.
+ color2 _ color1 negated.
+ fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
- | 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 changed:
----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') -----
wantsHaloFromClick
+
+ ^ self valueOfProperty: #wantsHaloFromClick ifAbsent: [^true].!
- ^ true!
Item was added:
+ ----- Method: MorphicProject>>exportSegmentInSexpWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') -----
+ exportSegmentInSexpWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: noInteraction
+
+ | fd sexp actualName |
+
+ world ifNil: [^ false].
+ world presenter ifNil: [^ false].
+ (world respondsTo: #sissScanObjectsAsEtoysProject) ifFalse: [^ false].
+
+ Command initialize.
+ world clearCommandHistory.
+ world cleanseStepList.
+ world localFlapTabs size = world flapTabs size ifFalse: [
+ noInteraction ifTrue: [^ false].
+ self error: 'Still holding onto Global flaps'].
+
+ fd _ aDirectory directoryNamed: self resourceDirectoryName.
+ fd assureExistence.
+
+ "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:[
+ sexp _ world sissScanObjectsAsEtoysProject.
+ ].
+ (aFileName endsWith: '.pr') ifTrue: [
+ actualName _ (aFileName copyFrom: 1 to: aFileName size - 3), '.sexp'.
+ ] ifFalse: [
+ actualName _ aFileName
+ ].
+
+ self
+ writeForExportInSexp: sexp withSources: actualName
+ inDirectory: fd
+ changeSet: aChangeSetOrNil.
+ SecurityManager default signFile: actualName directory: fd.
+ self storeHtmlPageIn: fd.
+ (world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new])
+ at: 'Project-Format' put: 'S-Expression'.
+ self storeManifestFileIn: fd.
+ self compressFilesIn: fd to: aFileName in: aDirectory.
+
+ ^ true
+ !
Item was changed:
----- 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."
+ ^ self exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: false!
- | 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: aChangeSetOrNil; add: thumbnail; 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>>exportSegmentWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') -----
+ exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName
+ directory: aDirectory withoutInteraction: noInteraction
+ "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].
+
+ Utilities emptyScrapsBook.
+ world cleanUpReferences.
+ 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: [
+ noInteraction ifTrue: [^ false].
+ self error: 'Still holding onto Global flaps'].
+ world releaseSqueakPages.
+ Smalltalk at: #ScriptEditorMorph ifPresent: [:s |
+ s writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false])].
+ 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: aChangeSetOrNil; add: thumbnail; 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 changed:
----- Method: MorphicProject>>updateLocaleDependents (in category 'language') -----
updateLocaleDependents
"Set the project's natural language as indicated"
ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
viewerOrScriptor localeChanged].
Flaps disableGlobalFlaps: false.
+ (Preferences eToyFriendly or: [Smalltalk globals at: #SugarNavigatorBar ifPresent: [:c | c showSugarNavigator] ifAbsent: [false]])
- Preferences eToyFriendly
ifTrue: [
Flaps addAndEnableEToyFlaps.
ActiveWorld addGlobalFlaps]
ifFalse: [Flaps enableGlobalFlaps].
(Project current isFlapIDEnabled: 'Navigator' translated)
ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].
ScrapBook default emptyScrapBook.
MenuIcons initializeTranslations.
super updateLocaleDependents.
"self setFlaps.
self setPaletteFor: aLanguageSymbol."
!
Item was changed:
----- 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 := 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 wantsMouseOverHalos: false.
proto beSticky.
^ proto!
Item was changed:
----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
"Answer a basis for names of default instances of the receiver"
+ ^ 'playfield' translatedNoop!
- ^ 'playfield'!
Item was changed:
----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') -----
addPenMenuItems: menu hand: aHandMorph
"Add a pen-trails-within submenu to the given menu"
+ menu add: 'pen trails...' translated target: self selector: #putUpPenTrailsSubmenu.
+ menu balloonTextForLastItem: 'its governing pen trails drawn within' translated!
- menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu!
Item was changed:
----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') -----
addPenTrailsMenuItemsTo: aMenu
"Add items relating to pen trails to aMenu"
| oldTarget |
+ oldTarget _ aMenu defaultTarget.
- 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 addLine.
+ aMenu addUpdating: #batchPenTrailsString action: #toggleBatchPenTrails.
+ aMenu balloonTextForLastItem: 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.' translated.
+
aMenu defaultTarget: oldTarget!
Item was changed:
----- Method: PasteUpMorph>>addWorldToggleItemsToHaloMenu: (in category 'menu & halo') -----
addWorldToggleItemsToHaloMenu: aMenu
+ "Add toggle items for the world to the halo menu .... July 2009: no longer in world halo menu"
- "Add toggle items for the world to the halo menu"
+ "aMenu addUpdating: #showTabsString
+ target: CurrentProjectRefactoring
+ action: #currentToggleFlapsSuppressed "!
- #(
- (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 changed:
----- 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.
+ self changed "redraw"
- self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
!
Item was changed:
----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') -----
chooseClickTarget
Cursor crossHair showWhile:
[Sensor waitButton].
Cursor down showWhile:
[Sensor anyButtonPressed].
+ ^ (self morphsAt: Sensor cursorPoint) first topRendererOrSelf!
- ^ (self morphsAt: Sensor cursorPoint) first!
Item was changed:
----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') -----
correspondingFlapTab
+ "If there is a flap tab whose referent is me, return it, else return nil. Will also work for flaps on the edge of embedded subareas such as within scripting-areas, but more slowly."
+
- "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]].
+
+ "Catch guys in embedded worldlets"
+ ActiveWorld allMorphs do:
+ [:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]].
+
^ nil!
Item was changed:
----- 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' translatedNoop]!
- ['world']!
Item was changed:
----- 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@0) anyShapeFill reverse.
+ screenForm _ Form fromDisplay: (topLeft extent: outline extent).
- outline := poly shadowForm.
- topLeft := outline offset.
- exterior := (outline offset: 0@0) anyShapeFill reverse.
- screenForm := Form fromDisplay: (topLeft extent: outline extent).
screenForm eraseShape: exterior.
+ innerForm _ screenForm trimBordersOfColor: Color transparent.
+ ActiveHand showTemporaryCursor: nil.
- innerForm := screenForm trimBordersOfColor: Color transparent.
innerForm isAllWhite ifFalse:
[hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was changed:
----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
flapTab
+ "Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'"
+
| ww |
self isFlap ifFalse:[^nil].
+ ww _ self presenter associatedMorph ifNil: [ActiveWorld].
+ ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]!
- ww := self world ifNil: [World].
- ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]!
Item was changed:
----- 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>'])
+ , 'grid visible when gridding' translated!
- , 'show grid when gridding' translated!
Item was changed:
----- Method: PasteUpMorph>>installFlaps (in category 'world state') -----
installFlaps
"Get flaps installed within the bounds of the receiver"
+ | localFlapTabs |
Project current assureFlapIntegrity.
self addGlobalFlaps.
+ localFlapTabs := self localFlapTabs.
+ localFlapTabs do: [:each | each visible: false].
+
+ Preferences eToyFriendly ifTrue: [
+ ProgressInitiationException display: 'Building Viewers...' translated
+ during: [:bar |
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld.
+ bar value: i / self localFlapTabs size]].
+ ] ifFalse: [
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld]].
+
- self localFlapTabs do:
- [:aFlapTab | aFlapTab adaptToWorld].
self assureFlapTabsFitOnScreen.
self bringTopmostsToFront!
Item was changed:
----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') -----
presentCardAndStackMenu
"Put up a menu holding card/stack-related options."
| aMenu |
+ aMenu _ MenuMorph new defaultTarget: self.
- aMenu := MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
+ aMenu addTitle: 'card and stack' translated.
+ aMenu add: 'add new card' translated action: #insertCard.
+ aMenu add: 'delete this card' translated action: #deleteCard.
+ aMenu add: 'go to next card' translated action: #goToNextCardInStack.
+ aMenu add: 'go to previous card' translated action: #goToPreviousCardInStack.
- 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' translated action: #showForegroundObjects.
+ aMenu add: 'show background objects' translated action: #showBackgroundObjects.
+ aMenu add: 'show designations' translated action: #showDesignationsOfObjects.
+ aMenu add: 'explain designations' translated action: #explainDesignations.
- 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 changed:
----- Method: PasteUpMorph>>referencePool (in category 'objects from disk') -----
referencePool
^ self
valueOfProperty: #References
+ ifAbsentPut: [WeakValueDictionary new]
+ !
- ifAbsentPut: [OrderedCollection new]
-
- !
Item was changed:
----- 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 changed:
----- 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]!
- aPlayer startRunning; step; stopRunning].
-
- self allScriptors do:
- [:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
- !
Item was changed:
----- 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 stopSound.
+ aPlayer stopRunning].
- aPlayer stopRunning].
- self allScriptors do:
- [:aScript | aScript pauseIfTicking].
self world updateStatusForAllScriptEditors!
Item was changed:
----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') -----
triggerClosingScripts
"If the receiver has any scripts set to run on closing, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllClosingScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllClosingScripts]!
Item was changed:
----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') -----
triggerOpeningScripts
"If the receiver has any scripts set to run on opening, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllOpeningScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllOpeningScripts]!
Item was changed:
----- 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:
+ [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]!
- [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 changed:
----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
setTextColor: aColor
"Set the color of my text to the given color"
+ textMorph textColor: aColor!
- textMorph color: aColor!
Item was changed:
----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Polygon' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ 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.' translatedNoop!
- ^ 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 changed:
----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu 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."
+
- addCustomMenuItems: aMenu hand: aHandMorph
- | |
super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles.
+ vertices size > 2 ifTrue:
+ [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed].
+
+ aMenu addUpdating: #smoothPhrase target: self action: #toggleSmoothing.
+ aMenu addLine.
+ aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
+
+ self isOpen ifTrue:
+ [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]].!
- 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 changed:
----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
+
+ ^ Color black
+
+ "Until September 2007, this had long been...
^ Color
r: 0.0
g: 0.419
+ b: 0.935"!
- b: 0.935!
Item was changed:
----- Method: PolygonMorph>>fillStyle (in category 'visual properties') -----
fillStyle
+ "Answer the receiver's fillStyle. For an *open* polygon, we return the borderColor, provided it's a true color rather than something strange like the symbol #raised."
+ | aColor |
self isOpen
+ ifTrue:
+ [(aColor := self borderColor) isColor ifTrue: [^ aColor]]. "easy access to line color from halo -- di's old note"
+
+ ^ super fillStyle!
- ifTrue: [^ self borderColor "easy access to line color from halo"]
- ifFalse: [^ super fillStyle]!
Item was changed:
----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') -----
handlesShowingPhrase
+ "Answer a phrase characterizing whether handles are showing or not."
+
+ ^ (self showingHandles ifTrue: ['<yes>'] ifFalse: ['<no>']), ('show handles' translated)!
- ^ (self showingHandles
- ifTrue: ['hide handles']
- ifFalse: ['show handles']) translated!
Item was changed:
----- Method: PolygonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
+ "Handle a mouse-down event."
+ ^ (evt shiftPressed and: [(self hasProperty: #activateOnShift) not])
- ^ 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 changed:
----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') -----
openOrClosePhrase
+ "Answer a string indicating whether the receiver is open or closed."
+
+ ^ (closed ifTrue: ['<yes>'] ifFalse: ['<no>']), 'closed' translated!
- | 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 changed:
----- Method: PolygonMorph>>stepTime (in category 'testing') -----
stepTime
+ "Answer the desired time between steps in milliseconds."
+ ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [100]
+
+ "NB: in all currently known cases, polygons are not actually wrapped in TransformationMorphs, so the #topRendererOrSelf call above is probably redundant, but is retained for safety."!
- ^ 100!
Item was changed:
----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') -----
+ verticesAt: anInteger put: aPoint
+
+ self vertices at: anInteger put: aPoint asFloatPoint.
- verticesAt: ix put: newPoint
- vertices at: ix put: newPoint.
self computeBounds!
Item was changed:
----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') -----
allCurrentlyTickingScriptInstantiations
+ "Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking."
+
+ ^ Array streamContents:
+ [:aStream |
+ self allExtantPlayers do:
+ [:aPlayer | aPlayer instantiatedUserScriptsDo:
+ [:aScriptInstantiation |
+ aScriptInstantiation status == #ticking ifTrue:
+ [aStream nextPut: aScriptInstantiation]]]]!
- ^#()!
Item was changed:
----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') -----
+ browseAllScriptsTextually
+ "Open a method-list browser on all the scripts in the project"
+
+ | aList aMethodList |
+ self flushPlayerListCache. "Just to be certain we get everything"
+
+ (aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players' translated].
+ aMethodList _ OrderedCollection new.
+ aList do:
+ [:aPair | aPair first addMethodReferencesTo: aMethodList].
+ aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!' translated].
+
+ SystemNavigation new
+ browseMessageList: aMethodList
+ name: 'All scripts in this project'
+ autoSelect: nil
+
+ "
+ ActiveWorld presenter browseAllScriptsTextually
+ "!
- browseAllScriptsTextually!
Item was changed:
----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'ProjectView' translatedNoop!
- ^ 'ProjectView'!
Item was changed:
----- 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' translatedNoop
- label: 'load as project'
selector: #openFromDirectoryAndFileName:
+ description: 'open project from file' translatedNoop
+ buttonLabel: 'load' translatedNoop
- description: 'open project from file'
- buttonLabel: 'load'
)
argumentGetter: [ :fileList | fileList dirAndFileName]!
Item was changed:
----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
+ "Accept -- in a custom sense here -- a morph dropped on the receiver."
| 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 dropEnabled ifFalse:
+ [^ 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.
- 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 changed:
----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
dismissViaHalo
+ "The user clicked on the dismiss icon on the halo."
+
| choice |
+ project ifNil: [^ self delete]. "no current project"
+ choice := (PopUpMenu labelArray:{
+ 'yes - delete icon and remove the project' translated.
+ 'no - delete icon but keep the project' translated.
+ 'cancel - do not delete anything' translated.
+ }) startUpWithCaption: ('Do you really want to delete the
+ project named {1}
+ and all its contents?' translated format: {project name printString}).
+ choice = 1 ifTrue: [^ self expungeProject].
+ choice = 2 ifTrue: [^ self delete]!
- 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 changed:
----- 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' translated
- ^self inform: 'The project is not present and may not be renamed now'
].
self addProjectNameMorph launchMiniEditor: evt.!
Item was changed:
----- 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' translated]].
- 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 changed:
----- Method: ProjectViewMorph>>fontForName (in category 'drawing') -----
fontForName
+ ^(TextStyle default fontOfSize: 15) emphasized: 1
- | 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 changed:
----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver."
+
super initialize.
+ "currentBorderColor _ Color gray."
+ self addProjectNameMorphFiller.
+ self enableDragNDrop: true.
+ self isOpaque: true.
+ !
- "currentBorderColor := Color gray."
- self addProjectNameMorphFiller.!
Item was changed:
----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
+ "Answer if the receiver would accept a drop of a given morph."
+ "If drop-enabled not set, answer false"
+ (super wantsDroppedMorph: aMorph event: evt) ifFalse: [^ false].
+
+ "If project not present, not morphic, or not initialized, answer false"
+ self isTheRealProjectPresent ifFalse: [^ false].
+ project isMorphic ifFalse: [^ false].
+ project world viewBox ifNil: [^ false].
+
+ ^ true!
- self isTheRealProjectPresent ifFalse: [^false].
- project isMorphic ifFalse: [^false].
- project world viewBox ifNil: [^false]. "uninitialized"
- ^true!
Item was changed:
----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Rectangle' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'A rectangular shape, with border and fill style' translatedNoop!
- ^ self partName: 'Rectangle'
- categories: #('Graphics' 'Basic')
- documentation: 'A rectangular shape, with border and fill style'!
Item was changed:
----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') -----
roundRectPrototype
+ "Answer a prototypical RoundRect object for a parts bin."
+
^ self authoringPrototype useRoundedCorners
+ color: (Color r: 1.0 g: 0.3 b: 0.6);
- color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5);
borderWidth: 1;
setNameTo: 'RoundRect'!
Item was changed:
----- 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].
+ (self valueOfProperty: #withMenuButton) == false ifTrue: [^ nil].
+ menu _ MenuMorph new defaultTarget: model.
+ aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
- menu := MenuMorph new defaultTarget: model.
- aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
getMenuSelector numArgs = 1 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu.
- [aMenu := model perform: getMenuSelector with: menu.
aTitle ifNotNil: [aMenu addTitle: aTitle].
^ aMenu].
getMenuSelector numArgs = 2 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
- [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 changed:
----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Selection' translatedNoop!
- ^ 'Selection'!
Item was changed:
----- 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}.
+ #-.
+ {'distribute vertically' translated. #distributeVertically}.
+ {'distribute horizontally' translated. #distributeHorizontally}.
+ }
- }.
+
- self selectedItems size > 2
- ifTrue:[
- aMenu addList: {
- #-.
- {'distribute vertically' translated. #distributeVertically}.
- {'distribute horizontally' translated. #distributeHorizontally}.
- }.
- ].
!
Item was changed:
----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
+ selectedItems do: [:m | m dismissViaHalo].
-
super dismissViaHalo.
+ !
- selectedItems do: [:m | m dismissViaHalo]!
Item was changed:
----- Method: SelectionMorph>>extent: (in category 'geometry') -----
extent: newExtent
+ "Set the receiver's extent Extend or contract the receiver's selection to encompass morphs within the new extent."
super extent: newExtent.
+ self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])!
- self selectSubmorphsOf: self pasteUpMorph!
Item was changed:
----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: evt
+ "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
selectedItems isEmpty ifTrue:
["Hand just clicked down to draw out a new selection"
^ self extendByHand: evt hand].
+ dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
- 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)] fixTemps].
+ selectedItems _ nil.
+ self removeHalo.
+ self halo ifNotNil: [self halo visible: false].
+ self delete.
- (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
evt wasHandled: true!
Item was changed:
----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') -----
selectSubmorphsOf: aMorph
+ "Given the receiver's current bounds, select submorphs of the indicated pasteup morph that fall entirely within those bounds. If nobody is within the bounds, delete the receiver."
| newItems removals |
+ newItems _ aMorph submorphs select:
- newItems := aMorph submorphs select:
[:m | (bounds containsRect: m fullBounds)
and: [m~~self
and: [(m isKindOf: HaloMorph) not]]].
+ otherSelection ifNil: [^ selectedItems _ newItems].
- otherSelection ifNil: [^ selectedItems := newItems].
+ removals _ newItems intersection: itemsAlreadySelected.
- removals := newItems intersection: itemsAlreadySelected.
otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
+ selectedItems _ (newItems copyWithoutAll: removals).
+ selectedItems ifEmpty: [self delete]
- selectedItems := (newItems copyWithoutAll: removals).
!
Item was changed:
----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') -----
slideToTrash: evt
self delete.
+ "selectedItems do: [:m | m slideToTrash: evt]"!
- selectedItems do: [:m | m slideToTrash: evt]!
Item was changed:
----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
hasContentsInExplorer
+ ^self notEmpty!
- ^self isEmpty not!
Item was changed:
----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
^ self = SimpleButtonMorph
+ ifTrue: ['Button' translatedNoop]
- ifTrue: ['Button']
ifFalse: [^ super defaultNameStemForInstances]!
Item was changed:
----- 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 action selector' translated action: #setActionSelector.
aCustomMenu add: 'change arguments' translated action: #setArguments.
aCustomMenu add: 'change when to act' translated action: #setActWhen.
+ aCustomMenu add: 'set target' translated action: #sightTargets:.
+ target ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]].
- self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
!
Item was changed:
----- 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:
+ [target perform: actionSelector withArguments: arguments].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments]].
actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]!
Item was changed:
----- 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."
+ ^ super 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.
+ Feb 2007: It seems unlikely that Squeak Pages will be used in the OLPC image. Don't use this code. Consider removing all code that supports SqueakPages."
+ "
| bb thatPage um stem ind sqPg |
(actionSelector == #goToPageMorph:fromBookmark:) |
(actionSelector == #goToPageMorph:) ifFalse: [
+ ^ super objectForDataStream: refStrm]. 'normal case'.
- ^ super objectForDataStream: refStrm]. "normal case"
+ target url ifNil: ['Later force target book to get a url.'.
+ bb _ SimpleButtonMorph new. 'write out a dummy'.
- 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.
- (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.
- 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.
- 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'.
- 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
+ "!
- ^ um!
Item was changed:
----- Method: SimpleButtonMorph>>updateVisualState: (in category 'visual properties') -----
updateVisualState: evt
oldColor ifNotNil: [
self color:
((self containsPoint: evt cursorPoint)
+ ifTrue: [oldColor mixed: 0.5 with: Color white]
- ifTrue: [oldColor mixed: 1/2 with: Color white]
ifFalse: [oldColor])]
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ self setProperty: #autoExpand toValue: false.
self
on: #mouseMove
send: #mouseStillDown:onItem:
to: self!
Item was changed:
----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Sketch' translatedNoop!
- ^ 'Sketch'!
Item was changed:
----- Method: SketchMorph>>addToggleItemsToHaloMenu: (in category 'menus') -----
addToggleItemsToHaloMenu: aCustomMenu
+ "Add toggle-items to the halo menu"
+
- "Add toggle-items to the halo menu"
super addToggleItemsToHaloMenu: aCustomMenu.
+ (Smalltalk includesKey: #B3DRenderEngine) ifTrue: [
+ aCustomMenu addUpdating: #useInterpolationString target: self action: #toggleInterpolation.
+ ].
+ !
- Preferences noviceMode
- ifFalse: [""aCustomMenu
- addUpdating: #useInterpolationString
- target: self
- action: #toggleInterpolation]!
Item was changed:
----- Method: SketchMorph>>collapse (in category 'menus') -----
collapse
+ "Replace the receiver with a collapsed rendition of itself."
-
- | priorPosition w collapsedVersion a |
+ | w collapsedVersion a ht tab |
+
+ (w _ self world) ifNil: [^self].
+ collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
- (w := self world) ifNil: [^self].
- collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph.
collapsedVersion setProperty: #uncollapsedMorph toValue: self.
collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
+
+ collapsedVersion setBalloonText: ('A collapsed version of {1}. Click to open it back up.' translated format: {self externalName}).
+
- collapsedVersion setBalloonText: 'A collapsed version of ',self name.
-
self delete.
w addMorphFront: (
+ a _ AlignmentMorph newRow
- a := AlignmentMorph newRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 4;
borderColor: Color white;
+ addMorph: collapsedVersion;
+ yourself).
+ a setNameTo: self externalName.
+ ht := (tab := Smalltalk at: #SugarNavTab ifPresent: [:c | ActiveWorld findA: c])
+ ifNotNil:
+ [tab height]
+ ifNil:
+ [80].
+ a position: 0@ht.
+
- addMorph: collapsedVersion
- ).
collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+ (self valueOfProperty: #collapsedPosition) ifNotNilDo:
+ [:priorPosition |
+ a position: priorPosition]!
- (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil])
- ifNotNil:
- [a position: priorPosition].
- !
Item was changed:
----- 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 x = 0 or: [newExtent y = 0]) ifTrue: [ ^self ].
- newExtent isZero ifTrue: [ ^self ].
self extent = newExtent ifTrue:[^self].
self scalePoint: newExtent asFloatPoint / (originalForm extent max: 1@1).
self layoutChanged.
!
Item was changed:
----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') -----
flipHorizontal
+ | r |
+ r _ self rotationCenter.
+ self left: self left - (1.0 - (2 * r x) * self width).
+ self form: (self form flipBy: #horizontal centerAt: self form center).
+ self rotationCenter: (1 - r x) @ (r y).!
- self form: (self form flipBy: #horizontal centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>flipVertical (in category 'e-toy support') -----
flipVertical
+ | r |
+ r _ self rotationCenter.
+ self top: self top - (1.0 - (2 * r y) * self height).
+ self form: (self form flipBy: #vertical centerAt: self form center).
+ self rotationCenter: r x @ (1 - r y).!
- self form: (self form flipBy: #vertical centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>initializeWith: (in category 'initialization') -----
initializeWith: aForm
super initialize.
+ originalForm _ aForm.
+ rotationStyle _ #normal. "styles: #normal, #leftRight, #upDown, or #none"
+ scalePoint _ 1.0(a)1.0.
+ framesToDwell _ 1.
+ rotatedForm _ originalForm. "cached rotation of originalForm"
- originalForm := aForm.
- self rotationCenter: 0.5(a)0.5. "relative to the top-left corner of the Form"
- rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none"
- scalePoint := 1.0(a)1.0.
- framesToDwell := 1.
- rotatedForm := originalForm. "cached rotation of originalForm"
self extent: originalForm extent.
!
Item was changed:
----- 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
+ Because my rendering code flips the form (see generateRotatedForm) we 'pre-flip' it here to preserve the same visual appearance.
+ "
- #none -- do not rotate"
+ | wasFlippedX wasFlippedY isFlippedX isFlippedY |
+ wasFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ wasFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ rotationStyle _ aSymbol.
+
+ isFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ isFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ wasFlippedX == isFlippedX
+ ifFalse: [self form: (self form flipBy: #horizontal centerAt: self form center)].
+ wasFlippedY == isFlippedY
+ ifFalse: [self form: (self form flipBy: #vertical centerAt: self form center)].
+
- rotationStyle := aSymbol.
self layoutChanged.
!
Item was changed:
----- Method: Slider>>sliderThickness (in category 'geometry') -----
sliderThickness
+ "^ 7"
+
+ | w |
+ w _ bounds isWide
+ ifTrue: [super height]
+ ifFalse: [super width].
+
+ ^ (w // 32) max: 16.
+ !
- ^ 7!
Item was changed:
----- 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: [FormDictionary at: #Cat]].
+ ^ FormDictionary at: #Cat!
- [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
- ^ nil!
Item was changed:
----- 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.
+ aCustomMenu addUpdating: #usePangoString target: self action: #toggleUsePango.
!
Item was changed:
----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
addOptionalHandlesTo: aHalo box: box
+ "eventually, add more handles for font..."
+
self flag: #deferred.
+ ^ super addOptionalHandlesTo: aHalo box: box
"Eventually...
self addFontHandlesTo: aHalo box: box"!
Item was changed:
----- 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 projectParameterAt: #substitutedFont).
+ (substituteFont notNil and: [self font == substituteFont])
- substituteFont := aProject projectParameters at:
- #substitutedFont ifAbsent: [#none].
- (substituteFont ~~ #none and: [self font == substituteFont])
ifTrue: [ self fitContents ].
^ super fixUponLoad: aProject seg: anImageSegment!
Item was changed:
----- Method: StringMorph>>font: (in category 'printing') -----
font: aFont
"Set the font my text will use. The emphasis remains unchanged."
+ aFont = font ifTrue: [^ self].
+ font _ aFont.
- font := aFont.
^ self font: font emphasis: emphasis!
Item was changed:
----- Method: StringMorphEditor>>initialize (in category 'display') -----
initialize
"Initialize the receiver. Give it a white background"
super initialize.
self backgroundColor: Color white.
+ self textColor: Color red.!
- self color: Color red!
Item was changed:
----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'TrueType banner' translatedNoop
+ categories: #()
+ documentation: 'A short text in a beautiful font. Use the resize handle to change size.' translatedNoop!
- ^ self partName: 'TrueType banner'
- categories: #('Demo')
- documentation: 'A short text in a beautiful font. Use the resize handle to change size.'!
Item was changed:
----- 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' translatedNoop. 'A scrolling data field which will have a different value on every card of the background' translatedNoop}
- 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 changed:
----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') -----
borderedPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t fontName: 'BitstreamVeraSans' pointSize: 24.
t autoFit: false; extent: 250@100.
+ t borderWidth: 1; margins: 4@0; backgroundColor: Color white.
- t borderWidth: 1; margins: 4@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 changed:
----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Text' translatedNoop!
- ^ 'Text'!
Item was changed:
----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') -----
fancyPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t autoFit: false; extent: 150@75.
t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?"
"fancy font, shadow, rounded"
+ t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; fillStyle: Color lightBrown.
- 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 changed:
----- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- 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' translatedNoop. 'A piece of text that will occur on every card of the background' translatedNoop}
- 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' translatedNoop. 'A data field which will have a different value on every card of the background' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you wish' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish')
forFlapNamed: 'Stack Tools'.
+ cl registerQuad: {#TextMorph . #fancyPrototype. 'Fancy Text' translatedNoop. 'A text field with a rounded shadowed border, with a fancy font.' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
forFlapNamed: 'Supplies'.]!
Item was changed:
----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+ (self backgroundColor isNil or: [self backgroundColor asColor isTranslucent])
- (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 changed:
----- Method: TextMorph>>backgroundColor (in category 'accessing') -----
backgroundColor
+ ^ self fillStyle.
+ !
- ^ backgroundColor!
Item was changed:
----- Method: TextMorph>>backgroundColor: (in category 'accessing') -----
backgroundColor: newColor
+ self fillStyle: newColor.
+ !
- backgroundColor := newColor.
- self changed!
Item was changed:
----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
beAllFont: aFont
+ textStyle _ TextStyle fontArray: (Array with: aFont).
+ text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)].
- textStyle := TextStyle fontArray: (Array with: aFont).
self releaseCachedState; changed!
Item was changed:
----- Method: TextMorph>>defaultLineHeight (in category 'geometry') -----
defaultLineHeight
+ ^ ( textStyle fontAt: textStyle defaultFontIndex) pointSize!
- ^ textStyle lineGrid!
Item was changed:
----- 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 wid |
- | newExtent para cBounds lastOfLines heightOfLast |
self isAutoFit
ifTrue:
+ [wid _ (text notNil and: [text size > 2]) ifTrue: [5] ifFalse: [40].
+ newExtent := (self paragraph extent max: wid @ ( self defaultLineHeight)) + (0 @ 2).
- [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 changed:
----- Method: TextMorph>>insertCharacters: (in category 'scripting access') -----
+ insertCharacters: aString
- insertCharacters: aSource
"Insert the characters from the given source at my current cursor position"
+ | aLoc aText attributes |
- | aLoc |
aLoc := self cursor max: 1.
+ aText := aLoc > text size
+ ifTrue: [aString asText]
+ ifFalse: [
+ attributes := (text attributesAt: aLoc)
+ select: [:attr | attr mayBeExtended].
+ Text string: aString attributes: attributes].
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aText displaying: true.
- paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
self updateFromParagraph !
Item was changed:
----- 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].
- [paragraph := nil].
container ifNotNil:
+ [container isMorph ifTrue: [container releaseCachedState]]!
- [container releaseCachedState]!
Item was changed:
----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') -----
setAllButFirstCharacter: source
"Set all but the first char of the receiver to the source"
+ | chars |
+ (chars _ self getCharacters) isEmpty
- | aChar chars |
- aChar := source asCharacter.
- (chars := self getCharacters) isEmpty
ifTrue: [self newContents: 'ยท' , source asString]
+ ifFalse: [self newContents: (String
- ifFalse: [chars first = aChar
- ifFalse: [""
- self
- newContents: (String
streamContents: [:aStream |
aStream nextPut: chars first.
+ aStream nextPutAll: source])]!
- aStream nextPutAll: source])]] !
Item was changed:
----- Method: TextMorph>>textColor: (in category 'accessing') -----
textColor: aColor
+ self editor selectFrom: 1 to: 0.
+ self selectionColor: aColor.
- color = aColor ifTrue: [^ self].
- color := aColor.
- self changed.
!
Item was changed:
----- Method: TheWorldMenu>>remoteMenu (in category 'construction') -----
remoteMenu
"Build the Telemorphic menu for the world."
+ ^self fillIn: (self menu: 'Telemorphic' translatedNoop) from: {
+ { 'local host address' translatedNoop. { #myWorld . #reportLocalAddress } }.
+ { 'connect remote user' translatedNoop. { #myWorld . #connectRemoteUser } }.
+ { 'disconnect remote user' translatedNoop. { #myWorld . #disconnectRemoteUser } }.
+ { 'disconnect all remote users' translatedNoop. { #myWorld . #disconnectAllRemoteUsers } }.
- ^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 changed:
----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') -----
windowsMenu
"Build the windows menu for the world."
+ ^ self fillIn: (self menu: 'windows' translatedNoop) from: {
+ { 'find window' translatedNoop. { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' translatedNoop}.
- ^ 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...' translatedNoop. { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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...' translatedNoop. { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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.' translatedNoop}.
- tile: new windows positioned so that they do not overlap others, if possible.'}.
nil.
+ { 'collapse all windows' translatedNoop. { #myWorld . #collapseAllWindows }. 'Reduce all open windows to collapsed forms that only show titles.' translatedNoop}.
+ { 'collapse all objects' translatedNoop. { #myWorld . #collapseAllWindowsAndNonWindows }. 'Reduce all open windows and all other objects on the desktop to labeled tabs' translatedNoop}.
+ { 'expand all' translatedNoop. { #myWorld . #expandAllCollapsedObjects }. 'Expand all collapsed windows and other collapsed objects back to their expanded forms.' translatedNoop}.
+
+ { 'close top window (w)' translatedNoop. { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.' translatedNoop}.
+ { 'send top window to back (\)' translatedNoop. { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.' translatedNoop}.
+ { 'move windows onscreen' translatedNoop. { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen' translatedNoop}.
- { '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' translatedNoop. { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.' translatedNoop}.
+ { 'delete non-windows' translatedNoop. { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.' translatedNoop}.
+ { 'delete both of the above' translatedNoop. { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' translatedNoop}.
- { '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 changed:
----- 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."
+ | args |
(target notNil and: [actionSelector notNil])
ifTrue:
+ [args := actionSelector numArgs > arguments size
+ ifTrue:
+ [arguments copyWith: ActiveEvent]
+ ifFalse:
+ [arguments].
+ Cursor normal
+ showWhile: [target perform: actionSelector withArguments: args].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments].
target isMorph ifTrue: [target changed]]!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| now dt |
- self state: #pressed.
actWhen == #buttonDown
+ ifTrue: [self doButtonAction].
+ actWhen == #buttonUp
+ ifTrue: [self state: #pressed].
+ actWhen == #whilePressed
+ ifTrue:
+ [self state: #pressed.
+ now _ Time millisecondClockValue.
- 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"
+ "NOTE: this delay is temporary disabled because it makes event reaction delay,
+ e.g. the action is not stopped even if you release the button... - Takashi"
+ [dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
+ self mouseStillDown: evt].
+ super mouseDown: evt!
- dt := Time millisecondClockValue - now max: 0. "Time it took to do"
- dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
- self mouseStillDown: evt.!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ (#(#buttonUp #whilePressed ) includes: actWhen)
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #pressed]
+ ifFalse: [self state: #off]].
+ super mouseMove: evt!
- 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 changed:
----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
- mouseUp: evt
"Allow on:send:to: to set the response to events other than actWhen"
+ actWhen == #buttonDown
+ ifTrue: [super mouseUp: evt].
+ actWhen == #buttonUp
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #on.
+ self doButtonAction: evt.
+ super mouseUp: evt]
+ ifFalse: [self state: #off.
+ target
+ ifNotNil: ["Allow owner to keep it selected for radio
+ buttons"
+ target mouseUpBalk: evt]]].
+ actWhen == #whilePressed
+ ifTrue: [self state: #off.
+ super mouseUp: evt]!
- 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 changed:
----- 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: [1]
- ifTrue: [ 2]
ifFalse: [1]!
Item was changed:
----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') -----
fitContents
+ | newExtent |
+ newExtent := self measureContents.
+ newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.
- | 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 changed:
----- Method: UpdatingStringMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver to have default values in its instance variables."
- "Initialie the receiver to have default values in its instance
- variables "
super initialize.
""
+ format _ #default.
- format := #default.
"formats: #string, #default"
+ target _ getSelector _ putSelector _ nil.
+ floatPrecision _ 1.
+ growable _ true.
+ stepTime _ nil.
+ autoAcceptOnFocusLoss _ true.
+ minimumWidth _ 8.
+ maximumWidth _ 366!
- target := getSelector := putSelector := nil.
- floatPrecision := 1.
- growable := true.
- stepTime := 50.
- autoAcceptOnFocusLoss := true.
- minimumWidth := 8.
- maximumWidth := 300!
Item was changed:
----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') -----
readFromTarget
"Update my readout from my target"
+ | v ret places |
- | v ret |
(target isNil or: [getSelector isNil]) ifTrue: [^contents].
+ ret _ self checkTarget.
- ret := self checkTarget.
ret ifFalse: [^ '0'].
+ ((target isMorph) or:[target isPlayerLike]) ifTrue:[
+ places _ target decimalPlacesForGetter: getSelector.
+ (places ~= nil and: [ places ~= (self valueOfProperty: #decimalPlaces ifAbsent: [0])]) ifTrue: [ self decimalPlaces: places ]].
v := target perform: getSelector. "scriptPerformer"
(v isKindOf: Text) ifTrue: [v := v asString].
^self acceptValueFromTarget: v!
Item was changed:
----- 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 := MenuMorph new.
aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
+ 0 to: 10 do:
- 0 to: 5 do:
[:places |
aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
aMenu popUpInWorld!
Item was changed:
----- Method: UpdatingStringMorph>>stepTime (in category 'testing') -----
stepTime
+ ^ stepTime ifNil: [200]
- ^ stepTime ifNil: [50]
!
Item was changed:
----- 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.
+ self setProperty: #decimalPlaces toValue: ((self valueOfProperty: #decimalPlaces ifAbsent: [0]) veryDeepCopyWith: 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.
!
1
0
Tim Felgentreff uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-tfel.1248.mcz
==================== Summary ====================
Name: Morphic-tfel.1248
Author: tfel
Time: 10 August 2016, 10:43:17.310848 am
UUID: cfd8d787-efb7-b445-94a7-bdb0d90b2de4
Ancestors: Morphic-tfel.1247
remove direct reference to Etoys
=============== Diff against Morphic-mt.1246 ===============
Item was changed:
----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
supplementaryPartsDescriptions
"Extra items for parts bins"
^ {DescriptionForPartsBin
+ formalName: 'Circle' translatedNoop
+ categoryList: {'Graphics' translatedNoop}
+ documentation: 'A circular shape' translatedNoop
- formalName: 'Circle1'
- categoryList: #('Graphics')
- documentation: 'A circular shape'
globalReceiverSymbol: #CircleMorph
nativitySelector: #newStandAlone.
+ DescriptionForPartsBin
+ formalName: 'Pin' translatedNoop
+ categoryList: {'Connectors' translatedNoop}
+ documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop
- "DescriptionForPartsBin
- formalName: 'Pin'
- categoryList: #('Connectors')
- documentation: 'An attachment point for Connectors that you can embed in another Morph.'
globalReceiverSymbol: #NCPinMorph
+ nativitySelector: #newPin.
- nativitySelector: #newPin."
}!
Item was changed:
SketchMorph subclass: #ColorPickerMorph
+ instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency noChart'
+ classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransparentBox TransText'
- 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 changed:
----- 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 @ 31. "<<<< the form was changed a bit??"
- 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 changed:
----- 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 insetBy: 2) fillColor: feedbackColor.
- originalForm fill: FeedbackBox fillColor: feedbackColor.
self form: originalForm.
+ selectedColor _ aColor.
- selectedColor := aColor.
updateContinuously ifTrue: [self updateTargetColor].
self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).!
Item was changed:
----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Ellipse' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'An elliptical or circular shape' translatedNoop!
- ^ self partName: 'Ellipse'
- categories: #('Graphics' 'Basic')
- documentation: 'An elliptical or circular shape'!
Item was changed:
----- Method: HaloMorph>>addDupHandle: (in category 'handles') -----
addDupHandle: haloSpec
"Add the halo that offers duplication, or, when shift is down, make-sibling"
+ | aSelector |
+ aSelector := innerTarget couldMakeSibling
+ ifTrue:
+ [#doDupOrMakeSibling:with:]
+ ifFalse:
+ [#doDup:with:].
- self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self
+ self addHandle: haloSpec on: #mouseDown send: aSelector to: self
+
!
Item was changed:
----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') -----
addHandlesForWorldHalos
"Add handles for world halos, like the man said"
| box w |
+ w _ self world ifNil:[target world].
- w := self world ifNil:[target world].
self removeAllMorphs. "remove old handles, if any"
self bounds: target bounds.
+ box _ w bounds insetBy: self handleSize // 2.
- box := w bounds insetBy: 9.
target addWorldHandlesTo: self box: box.
Preferences uniqueNamesInHalos ifTrue:
[innerTarget assureExternalName].
self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
+ growingOrRotating _ false.
- growingOrRotating := false.
self layoutChanged.
self changed.
!
Item was changed:
----- Method: HaloMorph>>addViewingHandle: (in category 'handles') -----
addViewingHandle: haloSpec
+ "If appropriate, add a special Viewing halo handle to the receiver. On 26 Sept 07, we decided to eliminate this item from the UI, so the code of is method is now commented out...
- "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 changed:
----- Method: HaloMorph>>basicBox (in category 'private') -----
basicBox
| aBox minSide anExtent w |
+ minSide _ 4 * self handleSize.
+ anExtent _ ((self width + self handleSize + 8) max: minSide) @
- 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].
- aBox := Rectangle center: self center extent: anExtent.
- w := self world ifNil:[target outermostWorldMorph].
^ w
ifNil:
[aBox]
ifNotNil:
+ [aBox intersect: (w viewBox insetBy: self handleSize // 2)]
- [aBox intersect: (w viewBox insetBy: 8@8)]
!
Item was changed:
----- Method: HaloMorph>>doDirection:with: (in category 'private') -----
doDirection: anEvent with: directionHandle
+ "The mouse went down on the forward-direction halo handle; respond appropriately."
+
anEvent hand obtainHalo: self.
+ anEvent shiftPressed
+ ifTrue:
+ [directionArrowAnchor _ (target point: target referencePosition in: self world) rounded.
+ self positionDirectionShaft: directionHandle.
+ self removeAllHandlesBut: directionHandle.
+ directionHandle setProperty: #trackDirectionArrow toValue: true]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: directionHandle]!
- self removeAllHandlesBut: directionHandle!
Item was changed:
----- Method: HaloMorph>>handleSize (in category 'private') -----
handleSize
^ Preferences biggerHandles
+ ifTrue: [30]
- ifTrue: [20]
ifFalse: [16]!
Item was changed:
----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') -----
prepareToTrackCenterOfRotation: evt with: rotationHandle
+ "The mouse went down on the center of rotation."
+
evt hand obtainHalo: self.
+ evt shiftPressed
+ ifTrue:
+ [self removeAllHandlesBut: rotationHandle.
+ rotationHandle setProperty: #trackCenterOfRotation toValue: true.
+ evt hand showTemporaryCursor: Cursor blank]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: rotationHandle]!
- evt shiftPressed ifTrue:[
- self removeAllHandlesBut: rotationHandle.
- ] ifFalse:[
- rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
- self startDrag: evt with: rotationHandle
- ].
- evt hand showTemporaryCursor: Cursor blank!
Item was changed:
----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') -----
setCenterOfRotation: evt with: rotationHandle
| localPt |
evt hand obtainHalo: self.
evt hand showTemporaryCursor: nil.
+ (rotationHandle hasProperty: #trackCenterOfRotation) ifTrue:
+ [localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
+ innerTarget setRotationCenterFrom: localPt].
+
+ rotationHandle removeProperty: #trackCenterOfRotation.
+ self endInteraction!
- (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
- localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
- innerTarget setRotationCenterFrom: localPt.
- ].
- rotationHandle removeProperty: #dragByCenterOfRotation.
- self endInteraction
- !
Item was changed:
----- 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"
+ (directionHandle hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ target setDirectionFrom: directionHandle center.
+ directionHandle removeProperty: #trackDirectionArrow.
+ self endInteraction]!
- anEvent hand obtainHalo: self.
- target setDirectionFrom: directionHandle center.
- self endInteraction!
Item was changed:
----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') -----
trackCenterOfRotation: anEvent with: rotationHandle
(rotationHandle hasProperty: #dragByCenterOfRotation)
ifTrue:[^self doDrag: anEvent with: rotationHandle].
+ (rotationHandle hasProperty: #trackCenterOfRotation)
+ ifTrue:
+ [anEvent hand obtainHalo: self.
+ rotationHandle center: anEvent cursorPoint]!
- anEvent hand obtainHalo: self.
- rotationHandle center: anEvent cursorPoint.!
Item was changed:
----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') -----
trackDirectionArrow: anEvent with: shaft
+ (shaft hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
+ self layoutChanged]!
- anEvent hand obtainHalo: self.
- shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
- self layoutChanged!
Item was changed:
----- Method: HandleMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self extent: 16 @ 16.
- self extent: 8 @ 8.
!
Item was changed:
----- Method: IconicButton>>stationarySetup (in category 'initialization') -----
stationarySetup
+ "Set up event handlers for mouse actions. Should be spelled stationery..."
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.
+
+ self on: #click send: #launchPartFromClick to: self!
- self on: #mouseUp send: #borderThick to: self.!
Item was changed:
----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Image' translatedNoop
+ categories: #()
+ documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.' translatedNoop!
- ^ 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 changed:
----- 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' translatedNoop. 'A non-editable picture of something' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Joystick' translatedNoop
+ categories: {'Basic' translatedNoop}
+ documentation: 'A joystick-like control' translatedNoop!
- ^ self partName: 'Joystick'
- categories: #('Useful')
- documentation: 'A joystick-like control'!
Item was changed:
----- 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' translatedNoop. 'A joystick-like control' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Scripting'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ "Answer a description for the parts bin."
+
+ ^ self partName: 'Line' translatedNoop
+ categories: {'Graphics' translatedNoop}
+ documentation: 'A straight line. Shift-click to get handles and move the ends.' translatedNoop!
- ^ self partName: 'Line'
- categories: #('Graphics' 'Basic')
- documentation: 'A straight line. Shift-click to get handles and move the ends.'!
Item was changed:
----- 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.
- ActiveWorld addMorph: self centeredNear: aPoint.
self world displayWorld. "show myself"
+ aBlock value]
+ ensure: [self delete]!
- aBlock value.
- self delete!
Item was changed:
----- Method: MenuIcons class>>iconForMenuItem: (in category 'menu decoration') -----
iconForMenuItem: anItem
+ "Answer the icon (or nil) corresponding to a given menu item."
- "Answer the icon (or nil) corresponding to the (translated) string."
+ | aKey |
+ aKey _ (anItem selector == #undoOrRedoCommand)
+ ifTrue:
+ ['undo (z)' translated] "Actual wording changes dynamically"
+ ifFalse:
+ [anItem contents asString].
+ ^ TranslatedIcons at: aKey asLowercase ifAbsent: [nil]!
- ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]!
Item was changed:
----- Method: MenuMorph>>delete (in category 'initialization') -----
delete
+ "Delete the receiver."
+
+ activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]].
+ self isFlexed ifTrue: [^ owner delete].
+ ^ super delete!
- activeSubMenu ifNotNil:[activeSubMenu delete].
- ^super delete!
Item was changed:
----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') -----
serviceLoadMorphFromFile
"Answer a service for loading a .morph file"
^ SimpleServiceEntry
provider: self
+ label: 'load as morph' translatedNoop
- label: 'load as morph'
selector: #fromFileName:
+ description: 'load as morph' translatedNoop
+ buttonLabel: 'load' translatedNoop!
- description: 'load as morph'
- buttonLabel: 'load'!
Item was changed:
----- 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 w |
+ menu _ MenuMorph new defaultTarget: self.
+ w _ self world.
+ self potentialEmbeddingTargets reverseDo: [:m |
+ menu add: (m == w ifTrue: ['desktop' translated] ifFalse: [m knownName ifNil:[m class name asString]]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}.
+ m == self topRendererOrSelf owner ifTrue:
+ [menu lastItem color: Color red]].
+ aMenu ifNotNil:
+ [menu submorphCount > 0
+ ifTrue:[aMenu add:'embed into' translated subMenu: 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 changed:
----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') -----
addFlexShell
"Wrap a rotating and scaling shell around this morph."
+ | oldHalo flexMorph myWorld anIndex morphOwner |
- | oldHalo flexMorph myWorld anIndex |
myWorld := self world.
+ oldHalo:= self halo.
+ self owner ifNotNil:[ morphOwner := self owner]
+ ifNil:[morphOwner := self currentWorld].
+
+ anIndex := morphOwner submorphIndexOf: self.
+ morphOwner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self)
- 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 changed:
----- Method: Morph>>addHaloActionsTo: (in category 'menus') -----
addHaloActionsTo: aMenu
"Add items to aMenu representing actions requestable via halo"
| subMenu |
+ subMenu _ MenuMorph new defaultTarget: self.
- 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 add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles.
subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.
+ subMenu add: 'tile representing this object' translated target: self action: #tearOffTile.
- 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 changed:
----- 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 notNil and: [aNumber <= submorphs size])
- (aNumber <= submorphs size)
ifTrue:
[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
ifFalse:
+ [self addMorphBack: aMorph]!
- [self addMorphBack: aMorph]
- !
Item was changed:
----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') -----
chooseNewGraphicCoexisting: aBoolean
"Allow the user to choose a different form for her form-based morph"
+
| replacee aGraphicalMenu |
+ self isInWorld ifFalse: "menu must have persisted for a not-in-world object."
+ [aGraphicalMenu := ActiveWorld submorphThat:
+ [:m | (m isKindOf: GraphicalMenu) and: [m target == self]]
+ ifNone:
+ [^ self].
+ ^ aGraphicalMenu show; flashBounds].
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 changed:
----- Method: Morph>>couldMakeSibling (in category 'testing') -----
couldMakeSibling
"Answer whether it is appropriate to ask the receiver to make a sibling"
+ ^ self isWorldMorph not!
- ^ true!
Item was changed:
----- Method: Morph>>goBehind (in category 'submorphs-add/remove') -----
goBehind
+ "Move the receiver to bottom z-order."
+ | topRend |
+ topRend := self topRendererOrSelf.
+ topRend owner ifNotNilDo:
+ [:own | own addMorphNearBack: topRend]
- owner addMorphNearBack: self.
!
Item was changed:
----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') -----
invokeMetaMenu: evt
+ "Put up the 'meta' menu, invoked via control-click, unless eToyFriendly is true."
+
| menu |
+ Preferences eToyFriendly ifTrue: [^ self].
+
+ menu _ self buildMetaMenu: evt.
- menu := self buildMetaMenu: evt.
menu addTitle: self externalName.
+ menu popUpEvent: evt in: self world!
- self world ifNotNil: [
- menu popUpEvent: evt in: self world
- ]!
Item was changed:
----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') -----
obtrudesBeyondContainer
"Answer whether the receiver obtrudes beyond the bounds of its container"
+ | top formerOwner |
- | top |
top := self topRendererOrSelf.
+ top owner ifNil: [^ false].
+ ^ top owner isHandMorph
+ ifTrue:
+ [((formerOwner := top formerOwner) notNil and: [formerOwner isInWorld])
+ ifFalse:
+ [false]
+ ifTrue:
+ [(formerOwner boundsInWorld containsRect: top boundsInWorld) not]]
+ ifFalse:
+ [(top owner bounds containsRect: top bounds) not]!
- (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
- ^(top owner bounds containsRect: top bounds) not!
Item was changed:
----- Method: Morph>>on:send:to: (in category 'event handling') -----
on: eventName send: selector to: recipient
+ "When the given event occurs, send the given selector to the given recipient. If the given selector is nil, rescind any earlier handling for the given event type,"
+
+ self eventHandler ifNil:
+ [selector ifNil: [^ self]. "Don't pointlessly create an event handler!!"
+ self eventHandler: EventHandler new].
- self eventHandler ifNil: [self eventHandler: EventHandler new].
self eventHandler on: eventName send: selector to: recipient!
Item was changed:
----- Method: Morph>>openViewerForArgument (in category 'player viewer') -----
openViewerForArgument
+ Cursor wait
+ showWhile: [self presenter viewMorph: self]!
- "Open up a viewer for a player associated with the morph in question. "
- self presenter viewMorph: self!
Item was changed:
----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') -----
overlapsShadowForm: itsShadow bounds: itsBounds
"Answer true if itsShadow and my shadow overlap at all"
+ | overlapExtent overlap myRect myShadow goalRect goalShadow bb |
+ overlap _ self fullBounds intersect: itsBounds.
+ overlapExtent _ overlap extent.
- | andForm overlapExtent |
- overlapExtent := (itsBounds intersect: self fullBounds) extent.
overlapExtent > (0 @ 0)
ifFalse: [^ false].
+ myRect := overlap translateBy: 0 @ 0 - self topLeft.
+ myShadow := (self imageForm contentsOfArea: myRect) stencil.
+ goalRect := overlap translateBy: 0 @ 0 - itsBounds topLeft.
+ goalShadow := (itsShadow contentsOfArea: goalRect) stencil.
+
+ "compute a pixel-by-pixel AND of the two stencils. Result will be black
+ (pixel value = 1) where black parts of the stencils overlap"
+ bb := BitBlt toForm: myShadow.
+ bb
+ copyForm: goalShadow
+ to: 0 @ 0
+ rule: Form and.
+
+ ^(bb destForm tallyPixelValues second) > 0 !
- 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 changed:
----- Method: Morph>>roundUpStrays (in category 'miscellaneous') -----
roundUpStrays
+ "Bring submorphs of playfieldlike structures in the receiver's interior back within view."
+
+ self submorphsDo:
+ [:m | m isPlayfieldLike ifTrue: [m roundUpStrays]]!
- self submorphs
- do: [:each | each roundUpStrays]!
Item was changed:
----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
slideBackToFormerSituation: evt
+ "A drop of the receiver having been rejected, slide it back to where it came from, if possible."
+
| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
formerOwner := self formerOwner.
formerPosition := self formerPosition.
+ (aWorld := evt hand world) ifNil: [^ self delete]. "Likely a moribund hand from an EventRecorder playback."
+
- 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.
+ "The OLPC Virtual Screen wouldn't notice the last update here."
+ Display forceToScreen: (endPoint extent: slideForm extent).
formerOwner addMorph: self.
self position: formerPosition.
self justDroppedInto: formerOwner event: evt!
Item was changed:
----- Method: Morph>>useGradientFill (in category 'visual properties') -----
useGradientFill
"Make receiver use a solid fill style (e.g., a simple color)"
+
+ | fill color1 color2 fil |
+ ((fil := self fillStyle) notNil and: [fil isSymbol not] and: [fil isGradientFill]) ifTrue:[^self]. "Already done"
+ color1 _ self color asColor.
+ color2 _ color1 negated.
+ fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
- | 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 changed:
----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') -----
wantsHaloFromClick
+
+ ^ self valueOfProperty: #wantsHaloFromClick ifAbsent: [^true].!
- ^ true!
Item was changed:
----- Method: MorphicProject>>updateLocaleDependents (in category 'language') -----
updateLocaleDependents
"Set the project's natural language as indicated"
ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
viewerOrScriptor localeChanged].
Flaps disableGlobalFlaps: false.
+ (Preferences eToyFriendly or: [Smalltalk globals at: #SugarNavigatorBar ifPresent: [:c | c showSugarNavigator] ifAbsent: [false]])
- Preferences eToyFriendly
ifTrue: [
Flaps addAndEnableEToyFlaps.
ActiveWorld addGlobalFlaps]
ifFalse: [Flaps enableGlobalFlaps].
(Project current isFlapIDEnabled: 'Navigator' translated)
ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].
ScrapBook default emptyScrapBook.
MenuIcons initializeTranslations.
super updateLocaleDependents.
"self setFlaps.
self setPaletteFor: aLanguageSymbol."
!
Item was changed:
----- 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 := 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 wantsMouseOverHalos: false.
proto beSticky.
^ proto!
Item was changed:
----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
"Answer a basis for names of default instances of the receiver"
+ ^ 'playfield' translatedNoop!
- ^ 'playfield'!
Item was changed:
----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') -----
addPenMenuItems: menu hand: aHandMorph
"Add a pen-trails-within submenu to the given menu"
+ menu add: 'pen trails...' translated target: self selector: #putUpPenTrailsSubmenu.
+ menu balloonTextForLastItem: 'its governing pen trails drawn within' translated!
- menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu!
Item was changed:
----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') -----
addPenTrailsMenuItemsTo: aMenu
"Add items relating to pen trails to aMenu"
| oldTarget |
+ oldTarget _ aMenu defaultTarget.
- 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 addLine.
+ aMenu addUpdating: #batchPenTrailsString action: #toggleBatchPenTrails.
+ aMenu balloonTextForLastItem: 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.' translated.
+
aMenu defaultTarget: oldTarget!
Item was changed:
----- Method: PasteUpMorph>>addWorldToggleItemsToHaloMenu: (in category 'menu & halo') -----
addWorldToggleItemsToHaloMenu: aMenu
+ "Add toggle items for the world to the halo menu .... July 2009: no longer in world halo menu"
- "Add toggle items for the world to the halo menu"
+ "aMenu addUpdating: #showTabsString
+ target: CurrentProjectRefactoring
+ action: #currentToggleFlapsSuppressed "!
- #(
- (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 changed:
----- 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.
+ self changed "redraw"
- self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
!
Item was changed:
----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') -----
chooseClickTarget
Cursor crossHair showWhile:
[Sensor waitButton].
Cursor down showWhile:
[Sensor anyButtonPressed].
+ ^ (self morphsAt: Sensor cursorPoint) first topRendererOrSelf!
- ^ (self morphsAt: Sensor cursorPoint) first!
Item was changed:
----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') -----
correspondingFlapTab
+ "If there is a flap tab whose referent is me, return it, else return nil. Will also work for flaps on the edge of embedded subareas such as within scripting-areas, but more slowly."
+
- "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]].
+
+ "Catch guys in embedded worldlets"
+ ActiveWorld allMorphs do:
+ [:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]].
+
^ nil!
Item was changed:
----- 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' translatedNoop]!
- ['world']!
Item was changed:
----- 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@0) anyShapeFill reverse.
+ screenForm _ Form fromDisplay: (topLeft extent: outline extent).
- outline := poly shadowForm.
- topLeft := outline offset.
- exterior := (outline offset: 0@0) anyShapeFill reverse.
- screenForm := Form fromDisplay: (topLeft extent: outline extent).
screenForm eraseShape: exterior.
+ innerForm _ screenForm trimBordersOfColor: Color transparent.
+ ActiveHand showTemporaryCursor: nil.
- innerForm := screenForm trimBordersOfColor: Color transparent.
innerForm isAllWhite ifFalse:
[hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was changed:
----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
flapTab
+ "Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'"
+
| ww |
self isFlap ifFalse:[^nil].
+ ww _ self presenter associatedMorph ifNil: [ActiveWorld].
+ ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]!
- ww := self world ifNil: [World].
- ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]!
Item was changed:
----- 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>'])
+ , 'grid visible when gridding' translated!
- , 'show grid when gridding' translated!
Item was changed:
----- Method: PasteUpMorph>>installFlaps (in category 'world state') -----
installFlaps
"Get flaps installed within the bounds of the receiver"
+ | localFlapTabs |
Project current assureFlapIntegrity.
self addGlobalFlaps.
+ localFlapTabs := self localFlapTabs.
+ localFlapTabs do: [:each | each visible: false].
+
+ Preferences eToyFriendly ifTrue: [
+ ProgressInitiationException display: 'Building Viewers...' translated
+ during: [:bar |
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld.
+ bar value: i / self localFlapTabs size]].
+ ] ifFalse: [
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld]].
+
- self localFlapTabs do:
- [:aFlapTab | aFlapTab adaptToWorld].
self assureFlapTabsFitOnScreen.
self bringTopmostsToFront!
Item was changed:
----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') -----
presentCardAndStackMenu
"Put up a menu holding card/stack-related options."
| aMenu |
+ aMenu _ MenuMorph new defaultTarget: self.
- aMenu := MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
+ aMenu addTitle: 'card and stack' translated.
+ aMenu add: 'add new card' translated action: #insertCard.
+ aMenu add: 'delete this card' translated action: #deleteCard.
+ aMenu add: 'go to next card' translated action: #goToNextCardInStack.
+ aMenu add: 'go to previous card' translated action: #goToPreviousCardInStack.
- 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' translated action: #showForegroundObjects.
+ aMenu add: 'show background objects' translated action: #showBackgroundObjects.
+ aMenu add: 'show designations' translated action: #showDesignationsOfObjects.
+ aMenu add: 'explain designations' translated action: #explainDesignations.
- 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 changed:
----- Method: PasteUpMorph>>referencePool (in category 'objects from disk') -----
referencePool
^ self
valueOfProperty: #References
+ ifAbsentPut: [WeakValueDictionary new]
+ !
- ifAbsentPut: [OrderedCollection new]
-
- !
Item was changed:
----- 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 changed:
----- 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]!
- aPlayer startRunning; step; stopRunning].
-
- self allScriptors do:
- [:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
- !
Item was changed:
----- 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 stopSound.
+ aPlayer stopRunning].
- aPlayer stopRunning].
- self allScriptors do:
- [:aScript | aScript pauseIfTicking].
self world updateStatusForAllScriptEditors!
Item was changed:
----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') -----
triggerClosingScripts
"If the receiver has any scripts set to run on closing, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllClosingScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllClosingScripts]!
Item was changed:
----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') -----
triggerOpeningScripts
"If the receiver has any scripts set to run on opening, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllOpeningScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllOpeningScripts]!
Item was changed:
----- 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:
+ [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]!
- [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 changed:
----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
setTextColor: aColor
"Set the color of my text to the given color"
+ textMorph textColor: aColor!
- textMorph color: aColor!
Item was changed:
----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Polygon' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ 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.' translatedNoop!
- ^ 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 changed:
----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu 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."
+
- addCustomMenuItems: aMenu hand: aHandMorph
- | |
super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles.
+ vertices size > 2 ifTrue:
+ [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed].
+
+ aMenu addUpdating: #smoothPhrase target: self action: #toggleSmoothing.
+ aMenu addLine.
+ aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
+
+ self isOpen ifTrue:
+ [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]].!
- 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 changed:
----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
+
+ ^ Color black
+
+ "Until September 2007, this had long been...
^ Color
r: 0.0
g: 0.419
+ b: 0.935"!
- b: 0.935!
Item was changed:
----- Method: PolygonMorph>>fillStyle (in category 'visual properties') -----
fillStyle
+ "Answer the receiver's fillStyle. For an *open* polygon, we return the borderColor, provided it's a true color rather than something strange like the symbol #raised."
+ | aColor |
self isOpen
+ ifTrue:
+ [(aColor := self borderColor) isColor ifTrue: [^ aColor]]. "easy access to line color from halo -- di's old note"
+
+ ^ super fillStyle!
- ifTrue: [^ self borderColor "easy access to line color from halo"]
- ifFalse: [^ super fillStyle]!
Item was changed:
----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') -----
handlesShowingPhrase
+ "Answer a phrase characterizing whether handles are showing or not."
+
+ ^ (self showingHandles ifTrue: ['<yes>'] ifFalse: ['<no>']), ('show handles' translated)!
- ^ (self showingHandles
- ifTrue: ['hide handles']
- ifFalse: ['show handles']) translated!
Item was changed:
----- Method: PolygonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
+ "Handle a mouse-down event."
+ ^ (evt shiftPressed and: [(self hasProperty: #activateOnShift) not])
- ^ 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 changed:
----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') -----
openOrClosePhrase
+ "Answer a string indicating whether the receiver is open or closed."
+
+ ^ (closed ifTrue: ['<yes>'] ifFalse: ['<no>']), 'closed' translated!
- | 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 changed:
----- Method: PolygonMorph>>stepTime (in category 'testing') -----
stepTime
+ "Answer the desired time between steps in milliseconds."
+ ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [100]
+
+ "NB: in all currently known cases, polygons are not actually wrapped in TransformationMorphs, so the #topRendererOrSelf call above is probably redundant, but is retained for safety."!
- ^ 100!
Item was changed:
----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') -----
+ verticesAt: anInteger put: aPoint
+
+ self vertices at: anInteger put: aPoint asFloatPoint.
- verticesAt: ix put: newPoint
- vertices at: ix put: newPoint.
self computeBounds!
Item was changed:
----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') -----
allCurrentlyTickingScriptInstantiations
+ "Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking."
+
+ ^ Array streamContents:
+ [:aStream |
+ self allExtantPlayers do:
+ [:aPlayer | aPlayer instantiatedUserScriptsDo:
+ [:aScriptInstantiation |
+ aScriptInstantiation status == #ticking ifTrue:
+ [aStream nextPut: aScriptInstantiation]]]]!
- ^#()!
Item was changed:
----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') -----
+ browseAllScriptsTextually
+ "Open a method-list browser on all the scripts in the project"
+
+ | aList aMethodList |
+ self flushPlayerListCache. "Just to be certain we get everything"
+
+ (aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players' translated].
+ aMethodList _ OrderedCollection new.
+ aList do:
+ [:aPair | aPair first addMethodReferencesTo: aMethodList].
+ aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!' translated].
+
+ SystemNavigation new
+ browseMessageList: aMethodList
+ name: 'All scripts in this project'
+ autoSelect: nil
+
+ "
+ ActiveWorld presenter browseAllScriptsTextually
+ "!
- browseAllScriptsTextually!
Item was changed:
----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'ProjectView' translatedNoop!
- ^ 'ProjectView'!
Item was changed:
----- 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' translatedNoop
- label: 'load as project'
selector: #openFromDirectoryAndFileName:
+ description: 'open project from file' translatedNoop
+ buttonLabel: 'load' translatedNoop
- description: 'open project from file'
- buttonLabel: 'load'
)
argumentGetter: [ :fileList | fileList dirAndFileName]!
Item was changed:
----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
+ "Accept -- in a custom sense here -- a morph dropped on the receiver."
| 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 dropEnabled ifFalse:
+ [^ 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.
- 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 changed:
----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
dismissViaHalo
+ "The user clicked on the dismiss icon on the halo."
+
| choice |
+ project ifNil: [^ self delete]. "no current project"
+ choice := (PopUpMenu labelArray:{
+ 'yes - delete icon and remove the project' translated.
+ 'no - delete icon but keep the project' translated.
+ 'cancel - do not delete anything' translated.
+ }) startUpWithCaption: ('Do you really want to delete the
+ project named {1}
+ and all its contents?' translated format: {project name printString}).
+ choice = 1 ifTrue: [^ self expungeProject].
+ choice = 2 ifTrue: [^ self delete]!
- 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 changed:
----- 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' translated
- ^self inform: 'The project is not present and may not be renamed now'
].
self addProjectNameMorph launchMiniEditor: evt.!
Item was changed:
----- 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' translated]].
- 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 changed:
----- Method: ProjectViewMorph>>fontForName (in category 'drawing') -----
fontForName
+ ^(TextStyle default fontOfSize: 15) emphasized: 1
- | 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 changed:
----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver."
+
super initialize.
+ "currentBorderColor _ Color gray."
+ self addProjectNameMorphFiller.
+ self enableDragNDrop: true.
+ self isOpaque: true.
+ !
- "currentBorderColor := Color gray."
- self addProjectNameMorphFiller.!
Item was changed:
----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
+ "Answer if the receiver would accept a drop of a given morph."
+ "If drop-enabled not set, answer false"
+ (super wantsDroppedMorph: aMorph event: evt) ifFalse: [^ false].
+
+ "If project not present, not morphic, or not initialized, answer false"
+ self isTheRealProjectPresent ifFalse: [^ false].
+ project isMorphic ifFalse: [^ false].
+ project world viewBox ifNil: [^ false].
+
+ ^ true!
- self isTheRealProjectPresent ifFalse: [^false].
- project isMorphic ifFalse: [^false].
- project world viewBox ifNil: [^false]. "uninitialized"
- ^true!
Item was changed:
----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Rectangle' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'A rectangular shape, with border and fill style' translatedNoop!
- ^ self partName: 'Rectangle'
- categories: #('Graphics' 'Basic')
- documentation: 'A rectangular shape, with border and fill style'!
Item was changed:
----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') -----
roundRectPrototype
+ "Answer a prototypical RoundRect object for a parts bin."
+
^ self authoringPrototype useRoundedCorners
+ color: (Color r: 1.0 g: 0.3 b: 0.6);
- color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5);
borderWidth: 1;
setNameTo: 'RoundRect'!
Item was changed:
----- 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].
+ (self valueOfProperty: #withMenuButton) == false ifTrue: [^ nil].
+ menu _ MenuMorph new defaultTarget: model.
+ aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
- menu := MenuMorph new defaultTarget: model.
- aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
getMenuSelector numArgs = 1 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu.
- [aMenu := model perform: getMenuSelector with: menu.
aTitle ifNotNil: [aMenu addTitle: aTitle].
^ aMenu].
getMenuSelector numArgs = 2 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
- [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 changed:
----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Selection' translatedNoop!
- ^ 'Selection'!
Item was changed:
----- 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}.
+ #-.
+ {'distribute vertically' translated. #distributeVertically}.
+ {'distribute horizontally' translated. #distributeHorizontally}.
+ }
- }.
+
- self selectedItems size > 2
- ifTrue:[
- aMenu addList: {
- #-.
- {'distribute vertically' translated. #distributeVertically}.
- {'distribute horizontally' translated. #distributeHorizontally}.
- }.
- ].
!
Item was changed:
----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
+ selectedItems do: [:m | m dismissViaHalo].
-
super dismissViaHalo.
+ !
- selectedItems do: [:m | m dismissViaHalo]!
Item was changed:
----- Method: SelectionMorph>>extent: (in category 'geometry') -----
extent: newExtent
+ "Set the receiver's extent Extend or contract the receiver's selection to encompass morphs within the new extent."
super extent: newExtent.
+ self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])!
- self selectSubmorphsOf: self pasteUpMorph!
Item was changed:
----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: evt
+ "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
selectedItems isEmpty ifTrue:
["Hand just clicked down to draw out a new selection"
^ self extendByHand: evt hand].
+ dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
- 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)] fixTemps].
+ selectedItems _ nil.
+ self removeHalo.
+ self halo ifNotNil: [self halo visible: false].
+ self delete.
- (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
evt wasHandled: true!
Item was changed:
----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') -----
selectSubmorphsOf: aMorph
+ "Given the receiver's current bounds, select submorphs of the indicated pasteup morph that fall entirely within those bounds. If nobody is within the bounds, delete the receiver."
| newItems removals |
+ newItems _ aMorph submorphs select:
- newItems := aMorph submorphs select:
[:m | (bounds containsRect: m fullBounds)
and: [m~~self
and: [(m isKindOf: HaloMorph) not]]].
+ otherSelection ifNil: [^ selectedItems _ newItems].
- otherSelection ifNil: [^ selectedItems := newItems].
+ removals _ newItems intersection: itemsAlreadySelected.
- removals := newItems intersection: itemsAlreadySelected.
otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
+ selectedItems _ (newItems copyWithoutAll: removals).
+ selectedItems ifEmpty: [self delete]
- selectedItems := (newItems copyWithoutAll: removals).
!
Item was changed:
----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') -----
slideToTrash: evt
self delete.
+ "selectedItems do: [:m | m slideToTrash: evt]"!
- selectedItems do: [:m | m slideToTrash: evt]!
Item was changed:
----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
hasContentsInExplorer
+ ^self notEmpty!
- ^self isEmpty not!
Item was changed:
----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
^ self = SimpleButtonMorph
+ ifTrue: ['Button' translatedNoop]
- ifTrue: ['Button']
ifFalse: [^ super defaultNameStemForInstances]!
Item was changed:
----- 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 action selector' translated action: #setActionSelector.
aCustomMenu add: 'change arguments' translated action: #setArguments.
aCustomMenu add: 'change when to act' translated action: #setActWhen.
+ aCustomMenu add: 'set target' translated action: #sightTargets:.
+ target ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]].
- self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
!
Item was changed:
----- 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:
+ [target perform: actionSelector withArguments: arguments].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments]].
actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]!
Item was changed:
----- 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."
+ ^ super 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.
+ Feb 2007: It seems unlikely that Squeak Pages will be used in the OLPC image. Don't use this code. Consider removing all code that supports SqueakPages."
+ "
| bb thatPage um stem ind sqPg |
(actionSelector == #goToPageMorph:fromBookmark:) |
(actionSelector == #goToPageMorph:) ifFalse: [
+ ^ super objectForDataStream: refStrm]. 'normal case'.
- ^ super objectForDataStream: refStrm]. "normal case"
+ target url ifNil: ['Later force target book to get a url.'.
+ bb _ SimpleButtonMorph new. 'write out a dummy'.
- 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.
- (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.
- 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.
- 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'.
- 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
+ "!
- ^ um!
Item was changed:
----- Method: SimpleButtonMorph>>updateVisualState: (in category 'visual properties') -----
updateVisualState: evt
oldColor ifNotNil: [
self color:
((self containsPoint: evt cursorPoint)
+ ifTrue: [oldColor mixed: 0.5 with: Color white]
- ifTrue: [oldColor mixed: 1/2 with: Color white]
ifFalse: [oldColor])]
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ self setProperty: #autoExpand toValue: false.
self
on: #mouseMove
send: #mouseStillDown:onItem:
to: self!
Item was changed:
----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Sketch' translatedNoop!
- ^ 'Sketch'!
Item was changed:
----- Method: SketchMorph>>addToggleItemsToHaloMenu: (in category 'menus') -----
addToggleItemsToHaloMenu: aCustomMenu
+ "Add toggle-items to the halo menu"
+
- "Add toggle-items to the halo menu"
super addToggleItemsToHaloMenu: aCustomMenu.
+ (Smalltalk includesKey: #B3DRenderEngine) ifTrue: [
+ aCustomMenu addUpdating: #useInterpolationString target: self action: #toggleInterpolation.
+ ].
+ !
- Preferences noviceMode
- ifFalse: [""aCustomMenu
- addUpdating: #useInterpolationString
- target: self
- action: #toggleInterpolation]!
Item was changed:
----- Method: SketchMorph>>collapse (in category 'menus') -----
collapse
+ "Replace the receiver with a collapsed rendition of itself."
-
- | priorPosition w collapsedVersion a |
+ | w collapsedVersion a ht tab |
+
+ (w _ self world) ifNil: [^self].
+ collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
- (w := self world) ifNil: [^self].
- collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph.
collapsedVersion setProperty: #uncollapsedMorph toValue: self.
collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
+
+ collapsedVersion setBalloonText: ('A collapsed version of {1}. Click to open it back up.' translated format: {self externalName}).
+
- collapsedVersion setBalloonText: 'A collapsed version of ',self name.
-
self delete.
w addMorphFront: (
+ a _ AlignmentMorph newRow
- a := AlignmentMorph newRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 4;
borderColor: Color white;
+ addMorph: collapsedVersion;
+ yourself).
+ a setNameTo: self externalName.
+ ht := (tab := Smalltalk at: #SugarNavTab ifPresent: [:c | ActiveWorld findA: c])
+ ifNotNil:
+ [tab height]
+ ifNil:
+ [80].
+ a position: 0@ht.
+
- addMorph: collapsedVersion
- ).
collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+ (self valueOfProperty: #collapsedPosition) ifNotNilDo:
+ [:priorPosition |
+ a position: priorPosition]!
- (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil])
- ifNotNil:
- [a position: priorPosition].
- !
Item was changed:
----- 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 x = 0 or: [newExtent y = 0]) ifTrue: [ ^self ].
- newExtent isZero ifTrue: [ ^self ].
self extent = newExtent ifTrue:[^self].
self scalePoint: newExtent asFloatPoint / (originalForm extent max: 1@1).
self layoutChanged.
!
Item was changed:
----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') -----
flipHorizontal
+ | r |
+ r _ self rotationCenter.
+ self left: self left - (1.0 - (2 * r x) * self width).
+ self form: (self form flipBy: #horizontal centerAt: self form center).
+ self rotationCenter: (1 - r x) @ (r y).!
- self form: (self form flipBy: #horizontal centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>flipVertical (in category 'e-toy support') -----
flipVertical
+ | r |
+ r _ self rotationCenter.
+ self top: self top - (1.0 - (2 * r y) * self height).
+ self form: (self form flipBy: #vertical centerAt: self form center).
+ self rotationCenter: r x @ (1 - r y).!
- self form: (self form flipBy: #vertical centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>initializeWith: (in category 'initialization') -----
initializeWith: aForm
super initialize.
+ originalForm _ aForm.
+ rotationStyle _ #normal. "styles: #normal, #leftRight, #upDown, or #none"
+ scalePoint _ 1.0(a)1.0.
+ framesToDwell _ 1.
+ rotatedForm _ originalForm. "cached rotation of originalForm"
- originalForm := aForm.
- self rotationCenter: 0.5(a)0.5. "relative to the top-left corner of the Form"
- rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none"
- scalePoint := 1.0(a)1.0.
- framesToDwell := 1.
- rotatedForm := originalForm. "cached rotation of originalForm"
self extent: originalForm extent.
!
Item was changed:
----- 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
+ Because my rendering code flips the form (see generateRotatedForm) we 'pre-flip' it here to preserve the same visual appearance.
+ "
- #none -- do not rotate"
+ | wasFlippedX wasFlippedY isFlippedX isFlippedY |
+ wasFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ wasFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ rotationStyle _ aSymbol.
+
+ isFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ isFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ wasFlippedX == isFlippedX
+ ifFalse: [self form: (self form flipBy: #horizontal centerAt: self form center)].
+ wasFlippedY == isFlippedY
+ ifFalse: [self form: (self form flipBy: #vertical centerAt: self form center)].
+
- rotationStyle := aSymbol.
self layoutChanged.
!
Item was changed:
----- Method: Slider>>sliderThickness (in category 'geometry') -----
sliderThickness
+ "^ 7"
+
+ | w |
+ w _ bounds isWide
+ ifTrue: [super height]
+ ifFalse: [super width].
+
+ ^ (w // 32) max: 16.
+ !
- ^ 7!
Item was changed:
----- 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: [FormDictionary at: #Cat]].
+ ^ FormDictionary at: #Cat!
- [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
- ^ nil!
Item was changed:
----- 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.
+ aCustomMenu addUpdating: #usePangoString target: self action: #toggleUsePango.
!
Item was changed:
----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
addOptionalHandlesTo: aHalo box: box
+ "eventually, add more handles for font..."
+
self flag: #deferred.
+ ^ super addOptionalHandlesTo: aHalo box: box
"Eventually...
self addFontHandlesTo: aHalo box: box"!
Item was changed:
----- 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 projectParameterAt: #substitutedFont).
+ (substituteFont notNil and: [self font == substituteFont])
- substituteFont := aProject projectParameters at:
- #substitutedFont ifAbsent: [#none].
- (substituteFont ~~ #none and: [self font == substituteFont])
ifTrue: [ self fitContents ].
^ super fixUponLoad: aProject seg: anImageSegment!
Item was changed:
----- Method: StringMorph>>font: (in category 'printing') -----
font: aFont
"Set the font my text will use. The emphasis remains unchanged."
+ aFont = font ifTrue: [^ self].
+ font _ aFont.
- font := aFont.
^ self font: font emphasis: emphasis!
Item was changed:
----- Method: StringMorphEditor>>initialize (in category 'display') -----
initialize
"Initialize the receiver. Give it a white background"
super initialize.
self backgroundColor: Color white.
+ self textColor: Color red.!
- self color: Color red!
Item was changed:
----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'TrueType banner' translatedNoop
+ categories: #()
+ documentation: 'A short text in a beautiful font. Use the resize handle to change size.' translatedNoop!
- ^ self partName: 'TrueType banner'
- categories: #('Demo')
- documentation: 'A short text in a beautiful font. Use the resize handle to change size.'!
Item was changed:
----- 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' translatedNoop. 'A scrolling data field which will have a different value on every card of the background' translatedNoop}
- 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 changed:
----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') -----
borderedPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t fontName: 'BitstreamVeraSans' pointSize: 24.
t autoFit: false; extent: 250@100.
+ t borderWidth: 1; margins: 4@0; backgroundColor: Color white.
- t borderWidth: 1; margins: 4@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 changed:
----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Text' translatedNoop!
- ^ 'Text'!
Item was changed:
----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') -----
fancyPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t autoFit: false; extent: 150@75.
t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?"
"fancy font, shadow, rounded"
+ t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; fillStyle: Color lightBrown.
- 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 changed:
----- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- 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' translatedNoop. 'A piece of text that will occur on every card of the background' translatedNoop}
- 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' translatedNoop. 'A data field which will have a different value on every card of the background' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you wish' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish')
forFlapNamed: 'Stack Tools'.
+ cl registerQuad: {#TextMorph . #fancyPrototype. 'Fancy Text' translatedNoop. 'A text field with a rounded shadowed border, with a fancy font.' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
forFlapNamed: 'Supplies'.]!
Item was changed:
----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+ (self backgroundColor isNil or: [self backgroundColor asColor isTranslucent])
- (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 changed:
----- Method: TextMorph>>backgroundColor (in category 'accessing') -----
backgroundColor
+ ^ self fillStyle.
+ !
- ^ backgroundColor!
Item was changed:
----- Method: TextMorph>>backgroundColor: (in category 'accessing') -----
backgroundColor: newColor
+ self fillStyle: newColor.
+ !
- backgroundColor := newColor.
- self changed!
Item was changed:
----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
beAllFont: aFont
+ textStyle _ TextStyle fontArray: (Array with: aFont).
+ text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)].
- textStyle := TextStyle fontArray: (Array with: aFont).
self releaseCachedState; changed!
Item was changed:
----- Method: TextMorph>>defaultLineHeight (in category 'geometry') -----
defaultLineHeight
+ ^ ( textStyle fontAt: textStyle defaultFontIndex) pointSize!
- ^ textStyle lineGrid!
Item was changed:
----- 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 wid |
- | newExtent para cBounds lastOfLines heightOfLast |
self isAutoFit
ifTrue:
+ [wid _ (text notNil and: [text size > 2]) ifTrue: [5] ifFalse: [40].
+ newExtent := (self paragraph extent max: wid @ ( self defaultLineHeight)) + (0 @ 2).
- [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 changed:
----- Method: TextMorph>>insertCharacters: (in category 'scripting access') -----
+ insertCharacters: aString
- insertCharacters: aSource
"Insert the characters from the given source at my current cursor position"
+ | aLoc aText attributes |
- | aLoc |
aLoc := self cursor max: 1.
+ aText := aLoc > text size
+ ifTrue: [aString asText]
+ ifFalse: [
+ attributes := (text attributesAt: aLoc)
+ select: [:attr | attr mayBeExtended].
+ Text string: aString attributes: attributes].
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aText displaying: true.
- paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
self updateFromParagraph !
Item was changed:
----- 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].
- [paragraph := nil].
container ifNotNil:
+ [container isMorph ifTrue: [container releaseCachedState]]!
- [container releaseCachedState]!
Item was changed:
----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') -----
setAllButFirstCharacter: source
"Set all but the first char of the receiver to the source"
+ | chars |
+ (chars _ self getCharacters) isEmpty
- | aChar chars |
- aChar := source asCharacter.
- (chars := self getCharacters) isEmpty
ifTrue: [self newContents: 'ยท' , source asString]
+ ifFalse: [self newContents: (String
- ifFalse: [chars first = aChar
- ifFalse: [""
- self
- newContents: (String
streamContents: [:aStream |
aStream nextPut: chars first.
+ aStream nextPutAll: source])]!
- aStream nextPutAll: source])]] !
Item was changed:
----- Method: TextMorph>>textColor: (in category 'accessing') -----
textColor: aColor
+ self editor selectFrom: 1 to: 0.
+ self selectionColor: aColor.
- color = aColor ifTrue: [^ self].
- color := aColor.
- self changed.
!
Item was changed:
----- Method: TheWorldMenu>>remoteMenu (in category 'construction') -----
remoteMenu
"Build the Telemorphic menu for the world."
+ ^self fillIn: (self menu: 'Telemorphic' translatedNoop) from: {
+ { 'local host address' translatedNoop. { #myWorld . #reportLocalAddress } }.
+ { 'connect remote user' translatedNoop. { #myWorld . #connectRemoteUser } }.
+ { 'disconnect remote user' translatedNoop. { #myWorld . #disconnectRemoteUser } }.
+ { 'disconnect all remote users' translatedNoop. { #myWorld . #disconnectAllRemoteUsers } }.
- ^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 changed:
----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') -----
windowsMenu
"Build the windows menu for the world."
+ ^ self fillIn: (self menu: 'windows' translatedNoop) from: {
+ { 'find window' translatedNoop. { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' translatedNoop}.
- ^ 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...' translatedNoop. { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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...' translatedNoop. { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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.' translatedNoop}.
- tile: new windows positioned so that they do not overlap others, if possible.'}.
nil.
+ { 'collapse all windows' translatedNoop. { #myWorld . #collapseAllWindows }. 'Reduce all open windows to collapsed forms that only show titles.' translatedNoop}.
+ { 'collapse all objects' translatedNoop. { #myWorld . #collapseAllWindowsAndNonWindows }. 'Reduce all open windows and all other objects on the desktop to labeled tabs' translatedNoop}.
+ { 'expand all' translatedNoop. { #myWorld . #expandAllCollapsedObjects }. 'Expand all collapsed windows and other collapsed objects back to their expanded forms.' translatedNoop}.
+
+ { 'close top window (w)' translatedNoop. { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.' translatedNoop}.
+ { 'send top window to back (\)' translatedNoop. { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.' translatedNoop}.
+ { 'move windows onscreen' translatedNoop. { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen' translatedNoop}.
- { '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' translatedNoop. { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.' translatedNoop}.
+ { 'delete non-windows' translatedNoop. { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.' translatedNoop}.
+ { 'delete both of the above' translatedNoop. { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' translatedNoop}.
- { '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 changed:
----- 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."
+ | args |
(target notNil and: [actionSelector notNil])
ifTrue:
+ [args := actionSelector numArgs > arguments size
+ ifTrue:
+ [arguments copyWith: ActiveEvent]
+ ifFalse:
+ [arguments].
+ Cursor normal
+ showWhile: [target perform: actionSelector withArguments: args].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments].
target isMorph ifTrue: [target changed]]!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| now dt |
- self state: #pressed.
actWhen == #buttonDown
+ ifTrue: [self doButtonAction].
+ actWhen == #buttonUp
+ ifTrue: [self state: #pressed].
+ actWhen == #whilePressed
+ ifTrue:
+ [self state: #pressed.
+ now _ Time millisecondClockValue.
- 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"
+ "NOTE: this delay is temporary disabled because it makes event reaction delay,
+ e.g. the action is not stopped even if you release the button... - Takashi"
+ [dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
+ self mouseStillDown: evt].
+ super mouseDown: evt!
- dt := Time millisecondClockValue - now max: 0. "Time it took to do"
- dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
- self mouseStillDown: evt.!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ (#(#buttonUp #whilePressed ) includes: actWhen)
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #pressed]
+ ifFalse: [self state: #off]].
+ super mouseMove: evt!
- 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 changed:
----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
- mouseUp: evt
"Allow on:send:to: to set the response to events other than actWhen"
+ actWhen == #buttonDown
+ ifTrue: [super mouseUp: evt].
+ actWhen == #buttonUp
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #on.
+ self doButtonAction: evt.
+ super mouseUp: evt]
+ ifFalse: [self state: #off.
+ target
+ ifNotNil: ["Allow owner to keep it selected for radio
+ buttons"
+ target mouseUpBalk: evt]]].
+ actWhen == #whilePressed
+ ifTrue: [self state: #off.
+ super mouseUp: evt]!
- 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 changed:
----- 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: [1]
- ifTrue: [ 2]
ifFalse: [1]!
Item was changed:
----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') -----
fitContents
+ | newExtent |
+ newExtent := self measureContents.
+ newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.
- | 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 changed:
----- Method: UpdatingStringMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver to have default values in its instance variables."
- "Initialie the receiver to have default values in its instance
- variables "
super initialize.
""
+ format _ #default.
- format := #default.
"formats: #string, #default"
+ target _ getSelector _ putSelector _ nil.
+ floatPrecision _ 1.
+ growable _ true.
+ stepTime _ nil.
+ autoAcceptOnFocusLoss _ true.
+ minimumWidth _ 8.
+ maximumWidth _ 366!
- target := getSelector := putSelector := nil.
- floatPrecision := 1.
- growable := true.
- stepTime := 50.
- autoAcceptOnFocusLoss := true.
- minimumWidth := 8.
- maximumWidth := 300!
Item was changed:
----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') -----
readFromTarget
"Update my readout from my target"
+ | v ret places |
- | v ret |
(target isNil or: [getSelector isNil]) ifTrue: [^contents].
+ ret _ self checkTarget.
- ret := self checkTarget.
ret ifFalse: [^ '0'].
+ ((target isMorph) or:[target isPlayerLike]) ifTrue:[
+ places _ target decimalPlacesForGetter: getSelector.
+ (places ~= nil and: [ places ~= (self valueOfProperty: #decimalPlaces ifAbsent: [0])]) ifTrue: [ self decimalPlaces: places ]].
v := target perform: getSelector. "scriptPerformer"
(v isKindOf: Text) ifTrue: [v := v asString].
^self acceptValueFromTarget: v!
Item was changed:
----- 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 := MenuMorph new.
aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
+ 0 to: 10 do:
- 0 to: 5 do:
[:places |
aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
aMenu popUpInWorld!
Item was changed:
----- Method: UpdatingStringMorph>>stepTime (in category 'testing') -----
stepTime
+ ^ stepTime ifNil: [200]
- ^ stepTime ifNil: [50]
!
Item was changed:
----- 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.
+ self setProperty: #decimalPlaces toValue: ((self valueOfProperty: #decimalPlaces ifAbsent: [0]) veryDeepCopyWith: 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.
!
1
0
Tim Felgentreff uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-tfel.1250.mcz
==================== Summary ====================
Name: Morphic-tfel.1250
Author: tfel
Time: 10 August 2016, 3:55:48.699665 pm
UUID: ee8f510a-fcd4-cf42-b2bb-92120f81f93b
Ancestors: Morphic-tfel.1249
be more reserved in novice mode about which things to show in the yellow button menu.
=============== Diff against Morphic-mt.1246 ===============
Item was changed:
----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
supplementaryPartsDescriptions
"Extra items for parts bins"
^ {DescriptionForPartsBin
+ formalName: 'Circle' translatedNoop
+ categoryList: {'Graphics' translatedNoop}
+ documentation: 'A circular shape' translatedNoop
- formalName: 'Circle1'
- categoryList: #('Graphics')
- documentation: 'A circular shape'
globalReceiverSymbol: #CircleMorph
nativitySelector: #newStandAlone.
+ DescriptionForPartsBin
+ formalName: 'Pin' translatedNoop
+ categoryList: {'Connectors' translatedNoop}
+ documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop
- "DescriptionForPartsBin
- formalName: 'Pin'
- categoryList: #('Connectors')
- documentation: 'An attachment point for Connectors that you can embed in another Morph.'
globalReceiverSymbol: #NCPinMorph
+ nativitySelector: #newPin.
- nativitySelector: #newPin."
}!
Item was changed:
SketchMorph subclass: #ColorPickerMorph
+ instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency noChart'
+ classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransparentBox TransText'
- 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 changed:
----- 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 @ 31. "<<<< the form was changed a bit??"
- 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 changed:
----- 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 insetBy: 2) fillColor: feedbackColor.
- originalForm fill: FeedbackBox fillColor: feedbackColor.
self form: originalForm.
+ selectedColor _ aColor.
- selectedColor := aColor.
updateContinuously ifTrue: [self updateTargetColor].
self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).!
Item was changed:
----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Ellipse' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'An elliptical or circular shape' translatedNoop!
- ^ self partName: 'Ellipse'
- categories: #('Graphics' 'Basic')
- documentation: 'An elliptical or circular shape'!
Item was changed:
----- Method: HaloMorph>>addDupHandle: (in category 'handles') -----
addDupHandle: haloSpec
"Add the halo that offers duplication, or, when shift is down, make-sibling"
+ | aSelector |
+ aSelector := innerTarget couldMakeSibling
+ ifTrue:
+ [#doDupOrMakeSibling:with:]
+ ifFalse:
+ [#doDup:with:].
- self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self
+ self addHandle: haloSpec on: #mouseDown send: aSelector to: self
+
!
Item was changed:
----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') -----
addHandlesForWorldHalos
"Add handles for world halos, like the man said"
| box w |
+ w _ self world ifNil:[target world].
- w := self world ifNil:[target world].
self removeAllMorphs. "remove old handles, if any"
self bounds: target bounds.
+ box _ w bounds insetBy: self handleSize // 2.
- box := w bounds insetBy: 9.
target addWorldHandlesTo: self box: box.
Preferences uniqueNamesInHalos ifTrue:
[innerTarget assureExternalName].
self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
+ growingOrRotating _ false.
- growingOrRotating := false.
self layoutChanged.
self changed.
!
Item was changed:
----- Method: HaloMorph>>addViewingHandle: (in category 'handles') -----
addViewingHandle: haloSpec
+ "If appropriate, add a special Viewing halo handle to the receiver. On 26 Sept 07, we decided to eliminate this item from the UI, so the code of is method is now commented out...
- "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 changed:
----- Method: HaloMorph>>basicBox (in category 'private') -----
basicBox
| aBox minSide anExtent w |
+ minSide _ 4 * self handleSize.
+ anExtent _ ((self width + self handleSize + 8) max: minSide) @
- 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].
- aBox := Rectangle center: self center extent: anExtent.
- w := self world ifNil:[target outermostWorldMorph].
^ w
ifNil:
[aBox]
ifNotNil:
+ [aBox intersect: (w viewBox insetBy: self handleSize // 2)]
- [aBox intersect: (w viewBox insetBy: 8@8)]
!
Item was changed:
----- Method: HaloMorph>>doDirection:with: (in category 'private') -----
doDirection: anEvent with: directionHandle
+ "The mouse went down on the forward-direction halo handle; respond appropriately."
+
anEvent hand obtainHalo: self.
+ anEvent shiftPressed
+ ifTrue:
+ [directionArrowAnchor _ (target point: target referencePosition in: self world) rounded.
+ self positionDirectionShaft: directionHandle.
+ self removeAllHandlesBut: directionHandle.
+ directionHandle setProperty: #trackDirectionArrow toValue: true]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: directionHandle]!
- self removeAllHandlesBut: directionHandle!
Item was changed:
----- Method: HaloMorph>>handleSize (in category 'private') -----
handleSize
^ Preferences biggerHandles
+ ifTrue: [30]
- ifTrue: [20]
ifFalse: [16]!
Item was changed:
----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') -----
prepareToTrackCenterOfRotation: evt with: rotationHandle
+ "The mouse went down on the center of rotation."
+
evt hand obtainHalo: self.
+ evt shiftPressed
+ ifTrue:
+ [self removeAllHandlesBut: rotationHandle.
+ rotationHandle setProperty: #trackCenterOfRotation toValue: true.
+ evt hand showTemporaryCursor: Cursor blank]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: rotationHandle]!
- evt shiftPressed ifTrue:[
- self removeAllHandlesBut: rotationHandle.
- ] ifFalse:[
- rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
- self startDrag: evt with: rotationHandle
- ].
- evt hand showTemporaryCursor: Cursor blank!
Item was changed:
----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') -----
setCenterOfRotation: evt with: rotationHandle
| localPt |
evt hand obtainHalo: self.
evt hand showTemporaryCursor: nil.
+ (rotationHandle hasProperty: #trackCenterOfRotation) ifTrue:
+ [localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
+ innerTarget setRotationCenterFrom: localPt].
+
+ rotationHandle removeProperty: #trackCenterOfRotation.
+ self endInteraction!
- (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
- localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
- innerTarget setRotationCenterFrom: localPt.
- ].
- rotationHandle removeProperty: #dragByCenterOfRotation.
- self endInteraction
- !
Item was changed:
----- 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"
+ (directionHandle hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ target setDirectionFrom: directionHandle center.
+ directionHandle removeProperty: #trackDirectionArrow.
+ self endInteraction]!
- anEvent hand obtainHalo: self.
- target setDirectionFrom: directionHandle center.
- self endInteraction!
Item was changed:
----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') -----
trackCenterOfRotation: anEvent with: rotationHandle
(rotationHandle hasProperty: #dragByCenterOfRotation)
ifTrue:[^self doDrag: anEvent with: rotationHandle].
+ (rotationHandle hasProperty: #trackCenterOfRotation)
+ ifTrue:
+ [anEvent hand obtainHalo: self.
+ rotationHandle center: anEvent cursorPoint]!
- anEvent hand obtainHalo: self.
- rotationHandle center: anEvent cursorPoint.!
Item was changed:
----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') -----
trackDirectionArrow: anEvent with: shaft
+ (shaft hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
+ self layoutChanged]!
- anEvent hand obtainHalo: self.
- shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
- self layoutChanged!
Item was changed:
----- Method: HandleMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self extent: 16 @ 16.
- self extent: 8 @ 8.
!
Item was changed:
----- Method: IconicButton>>stationarySetup (in category 'initialization') -----
stationarySetup
+ "Set up event handlers for mouse actions. Should be spelled stationery..."
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.
+
+ self on: #click send: #launchPartFromClick to: self!
- self on: #mouseUp send: #borderThick to: self.!
Item was changed:
----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Image' translatedNoop
+ categories: #()
+ documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.' translatedNoop!
- ^ 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 changed:
----- 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' translatedNoop. 'A non-editable picture of something' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Joystick' translatedNoop
+ categories: {'Basic' translatedNoop}
+ documentation: 'A joystick-like control' translatedNoop!
- ^ self partName: 'Joystick'
- categories: #('Useful')
- documentation: 'A joystick-like control'!
Item was changed:
----- 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' translatedNoop. 'A joystick-like control' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Scripting'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ "Answer a description for the parts bin."
+
+ ^ self partName: 'Line' translatedNoop
+ categories: {'Graphics' translatedNoop}
+ documentation: 'A straight line. Shift-click to get handles and move the ends.' translatedNoop!
- ^ self partName: 'Line'
- categories: #('Graphics' 'Basic')
- documentation: 'A straight line. Shift-click to get handles and move the ends.'!
Item was changed:
----- 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.
- ActiveWorld addMorph: self centeredNear: aPoint.
self world displayWorld. "show myself"
+ aBlock value]
+ ensure: [self delete]!
- aBlock value.
- self delete!
Item was changed:
----- Method: MenuIcons class>>iconForMenuItem: (in category 'menu decoration') -----
iconForMenuItem: anItem
+ "Answer the icon (or nil) corresponding to a given menu item."
- "Answer the icon (or nil) corresponding to the (translated) string."
+ | aKey |
+ aKey _ (anItem selector == #undoOrRedoCommand)
+ ifTrue:
+ ['undo (z)' translated] "Actual wording changes dynamically"
+ ifFalse:
+ [anItem contents asString].
+ ^ TranslatedIcons at: aKey asLowercase ifAbsent: [nil]!
- ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]!
Item was changed:
----- Method: MenuMorph>>delete (in category 'initialization') -----
delete
+ "Delete the receiver."
+
+ activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]].
+ self isFlexed ifTrue: [^ owner delete].
+ ^ super delete!
- activeSubMenu ifNotNil:[activeSubMenu delete].
- ^super delete!
Item was changed:
----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') -----
serviceLoadMorphFromFile
"Answer a service for loading a .morph file"
^ SimpleServiceEntry
provider: self
+ label: 'load as morph' translatedNoop
- label: 'load as morph'
selector: #fromFileName:
+ description: 'load as morph' translatedNoop
+ buttonLabel: 'load' translatedNoop!
- description: 'load as morph'
- buttonLabel: 'load'!
Item was changed:
----- 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 w |
+ menu _ MenuMorph new defaultTarget: self.
+ w _ self world.
+ self potentialEmbeddingTargets reverseDo: [:m |
+ menu add: (m == w ifTrue: ['desktop' translated] ifFalse: [m knownName ifNil:[m class name asString]]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}.
+ m == self topRendererOrSelf owner ifTrue:
+ [menu lastItem color: Color red]].
+ aMenu ifNotNil:
+ [menu submorphCount > 0
+ ifTrue:[aMenu add:'embed into' translated subMenu: 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 changed:
----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') -----
addFlexShell
"Wrap a rotating and scaling shell around this morph."
+ | oldHalo flexMorph myWorld anIndex morphOwner |
- | oldHalo flexMorph myWorld anIndex |
myWorld := self world.
+ oldHalo:= self halo.
+ self owner ifNotNil:[ morphOwner := self owner]
+ ifNil:[morphOwner := self currentWorld].
+
+ anIndex := morphOwner submorphIndexOf: self.
+ morphOwner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self)
- 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 changed:
----- Method: Morph>>addHaloActionsTo: (in category 'menus') -----
addHaloActionsTo: aMenu
"Add items to aMenu representing actions requestable via halo"
| subMenu |
+ subMenu _ MenuMorph new defaultTarget: self.
- 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 add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles.
subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.
+ subMenu add: 'tile representing this object' translated target: self action: #tearOffTile.
- 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 changed:
----- 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 notNil and: [aNumber <= submorphs size])
- (aNumber <= submorphs size)
ifTrue:
[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
ifFalse:
+ [self addMorphBack: aMorph]!
- [self addMorphBack: aMorph]
- !
Item was changed:
----- 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 and: [Preferences noviceMode not])
- 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 changed:
----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') -----
chooseNewGraphicCoexisting: aBoolean
"Allow the user to choose a different form for her form-based morph"
+
| replacee aGraphicalMenu |
+ self isInWorld ifFalse: "menu must have persisted for a not-in-world object."
+ [aGraphicalMenu := ActiveWorld submorphThat:
+ [:m | (m isKindOf: GraphicalMenu) and: [m target == self]]
+ ifNone:
+ [^ self].
+ ^ aGraphicalMenu show; flashBounds].
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 changed:
----- Method: Morph>>couldMakeSibling (in category 'testing') -----
couldMakeSibling
"Answer whether it is appropriate to ask the receiver to make a sibling"
+ ^ self isWorldMorph not!
- ^ true!
Item was changed:
----- Method: Morph>>goBehind (in category 'submorphs-add/remove') -----
goBehind
+ "Move the receiver to bottom z-order."
+ | topRend |
+ topRend := self topRendererOrSelf.
+ topRend owner ifNotNilDo:
+ [:own | own addMorphNearBack: topRend]
- owner addMorphNearBack: self.
!
Item was changed:
----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') -----
invokeMetaMenu: evt
+ "Put up the 'meta' menu, invoked via control-click, unless eToyFriendly is true."
+
| menu |
+ Preferences eToyFriendly ifTrue: [^ self].
+
+ menu _ self buildMetaMenu: evt.
- menu := self buildMetaMenu: evt.
menu addTitle: self externalName.
+ menu popUpEvent: evt in: self world!
- self world ifNotNil: [
- menu popUpEvent: evt in: self world
- ]!
Item was changed:
----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') -----
obtrudesBeyondContainer
"Answer whether the receiver obtrudes beyond the bounds of its container"
+ | top formerOwner |
- | top |
top := self topRendererOrSelf.
+ top owner ifNil: [^ false].
+ ^ top owner isHandMorph
+ ifTrue:
+ [((formerOwner := top formerOwner) notNil and: [formerOwner isInWorld])
+ ifFalse:
+ [false]
+ ifTrue:
+ [(formerOwner boundsInWorld containsRect: top boundsInWorld) not]]
+ ifFalse:
+ [(top owner bounds containsRect: top bounds) not]!
- (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
- ^(top owner bounds containsRect: top bounds) not!
Item was changed:
----- Method: Morph>>on:send:to: (in category 'event handling') -----
on: eventName send: selector to: recipient
+ "When the given event occurs, send the given selector to the given recipient. If the given selector is nil, rescind any earlier handling for the given event type,"
+
+ self eventHandler ifNil:
+ [selector ifNil: [^ self]. "Don't pointlessly create an event handler!!"
+ self eventHandler: EventHandler new].
- self eventHandler ifNil: [self eventHandler: EventHandler new].
self eventHandler on: eventName send: selector to: recipient!
Item was changed:
----- Method: Morph>>openViewerForArgument (in category 'player viewer') -----
openViewerForArgument
+ Cursor wait
+ showWhile: [self presenter viewMorph: self]!
- "Open up a viewer for a player associated with the morph in question. "
- self presenter viewMorph: self!
Item was changed:
----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') -----
overlapsShadowForm: itsShadow bounds: itsBounds
"Answer true if itsShadow and my shadow overlap at all"
+ | overlapExtent overlap myRect myShadow goalRect goalShadow bb |
+ overlap _ self fullBounds intersect: itsBounds.
+ overlapExtent _ overlap extent.
- | andForm overlapExtent |
- overlapExtent := (itsBounds intersect: self fullBounds) extent.
overlapExtent > (0 @ 0)
ifFalse: [^ false].
+ myRect := overlap translateBy: 0 @ 0 - self topLeft.
+ myShadow := (self imageForm contentsOfArea: myRect) stencil.
+ goalRect := overlap translateBy: 0 @ 0 - itsBounds topLeft.
+ goalShadow := (itsShadow contentsOfArea: goalRect) stencil.
+
+ "compute a pixel-by-pixel AND of the two stencils. Result will be black
+ (pixel value = 1) where black parts of the stencils overlap"
+ bb := BitBlt toForm: myShadow.
+ bb
+ copyForm: goalShadow
+ to: 0 @ 0
+ rule: Form and.
+
+ ^(bb destForm tallyPixelValues second) > 0 !
- 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 changed:
----- Method: Morph>>roundUpStrays (in category 'miscellaneous') -----
roundUpStrays
+ "Bring submorphs of playfieldlike structures in the receiver's interior back within view."
+
+ self submorphsDo:
+ [:m | m isPlayfieldLike ifTrue: [m roundUpStrays]]!
- self submorphs
- do: [:each | each roundUpStrays]!
Item was changed:
----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
slideBackToFormerSituation: evt
+ "A drop of the receiver having been rejected, slide it back to where it came from, if possible."
+
| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
formerOwner := self formerOwner.
formerPosition := self formerPosition.
+ (aWorld := evt hand world) ifNil: [^ self delete]. "Likely a moribund hand from an EventRecorder playback."
+
- 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.
+ "The OLPC Virtual Screen wouldn't notice the last update here."
+ Display forceToScreen: (endPoint extent: slideForm extent).
formerOwner addMorph: self.
self position: formerPosition.
self justDroppedInto: formerOwner event: evt!
Item was changed:
----- Method: Morph>>useGradientFill (in category 'visual properties') -----
useGradientFill
"Make receiver use a solid fill style (e.g., a simple color)"
+
+ | fill color1 color2 fil |
+ ((fil := self fillStyle) notNil and: [fil isSymbol not] and: [fil isGradientFill]) ifTrue:[^self]. "Already done"
+ color1 _ self color asColor.
+ color2 _ color1 negated.
+ fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
- | 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 changed:
----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') -----
wantsHaloFromClick
+
+ ^ self valueOfProperty: #wantsHaloFromClick ifAbsent: [^true].!
- ^ true!
Item was added:
+ ----- Method: MorphicModel>>addModelYellowButtonMenuItemsTo:forMorph:hand: (in category 'graph model') -----
+ addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph
+
+ Preferences noviceMode ifFalse: [
+ super addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph].
+ ^ aCustomMenu!
Item was added:
+ ----- Method: MorphicProject>>exportSegmentInSexpWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') -----
+ exportSegmentInSexpWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: noInteraction
+
+ | fd sexp actualName |
+
+ world ifNil: [^ false].
+ world presenter ifNil: [^ false].
+ (world respondsTo: #sissScanObjectsAsEtoysProject) ifFalse: [^ false].
+
+ Command initialize.
+ world clearCommandHistory.
+ world cleanseStepList.
+ world localFlapTabs size = world flapTabs size ifFalse: [
+ noInteraction ifTrue: [^ false].
+ self error: 'Still holding onto Global flaps'].
+
+ fd _ aDirectory directoryNamed: self resourceDirectoryName.
+ fd assureExistence.
+
+ "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:[
+ sexp _ world sissScanObjectsAsEtoysProject.
+ ].
+ (aFileName endsWith: '.pr') ifTrue: [
+ actualName _ (aFileName copyFrom: 1 to: aFileName size - 3), '.sexp'.
+ ] ifFalse: [
+ actualName _ aFileName
+ ].
+
+ self
+ writeForExportInSexp: sexp withSources: actualName
+ inDirectory: fd
+ changeSet: aChangeSetOrNil.
+ SecurityManager default signFile: actualName directory: fd.
+ self storeHtmlPageIn: fd.
+ (world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new])
+ at: 'Project-Format' put: 'S-Expression'.
+ self storeManifestFileIn: fd.
+ self compressFilesIn: fd to: aFileName in: aDirectory.
+
+ ^ true
+ !
Item was changed:
----- 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."
+ ^ self exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: false!
- | 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: aChangeSetOrNil; add: thumbnail; 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>>exportSegmentWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') -----
+ exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName
+ directory: aDirectory withoutInteraction: noInteraction
+ "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].
+
+ Utilities emptyScrapsBook.
+ world cleanUpReferences.
+ 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: [
+ noInteraction ifTrue: [^ false].
+ self error: 'Still holding onto Global flaps'].
+ world releaseSqueakPages.
+ Smalltalk at: #ScriptEditorMorph ifPresent: [:s |
+ s writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false])].
+ 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: aChangeSetOrNil; add: thumbnail; 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 changed:
----- Method: MorphicProject>>updateLocaleDependents (in category 'language') -----
updateLocaleDependents
"Set the project's natural language as indicated"
ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
viewerOrScriptor localeChanged].
Flaps disableGlobalFlaps: false.
+ (Preferences eToyFriendly or: [Smalltalk globals at: #SugarNavigatorBar ifPresent: [:c | c showSugarNavigator] ifAbsent: [false]])
- Preferences eToyFriendly
ifTrue: [
Flaps addAndEnableEToyFlaps.
ActiveWorld addGlobalFlaps]
ifFalse: [Flaps enableGlobalFlaps].
(Project current isFlapIDEnabled: 'Navigator' translated)
ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].
ScrapBook default emptyScrapBook.
MenuIcons initializeTranslations.
super updateLocaleDependents.
"self setFlaps.
self setPaletteFor: aLanguageSymbol."
!
Item was changed:
----- 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 := 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 wantsMouseOverHalos: false.
proto beSticky.
^ proto!
Item was changed:
----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
"Answer a basis for names of default instances of the receiver"
+ ^ 'playfield' translatedNoop!
- ^ 'playfield'!
Item was changed:
----- Method: PasteUpMorph>>addCustomMenuItems:hand: (in category 'menu & halo') -----
addCustomMenuItems: menu hand: aHandMorph
"Add morph-specific menu itemns to the menu for the hand"
+ | twm |
super addCustomMenuItems: menu hand: aHandMorph.
- menu addLine.
Preferences noviceMode
ifFalse: [
+ menu addLine.
self addStackMenuItems: menu hand: aHandMorph.
self addPenMenuItems: menu hand: aHandMorph.
self addPlayfieldMenuItems: menu hand: aHandMorph].
+ (self isWorldMorph and: [Preferences noviceMode not])
- self isWorldMorph
ifTrue: [
menu addLine.
+ (owner isKindOf: BOBTransformationMorph)
+ ifTrue: [self addScalingMenuItems: menu hand: aHandMorph].
- 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.
+ menu addLine.
- twm := TheWorldMenu new.
- twm world: self project: Project current hand: aHandMorph.
+ twm := TheWorldMenu new.
+ twm world: self project: Project current hand: aHandMorph.
+
+ menu add: 'old desktop menu... (W)' translated subMenu: twm buildWorldMenu.
- menu add: 'old desktop menu... (W)' translated subMenu: twm buildWorldMenu.
- ].
].
!
Item was changed:
----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') -----
addPenMenuItems: menu hand: aHandMorph
"Add a pen-trails-within submenu to the given menu"
+ menu add: 'pen trails...' translated target: self selector: #putUpPenTrailsSubmenu.
+ menu balloonTextForLastItem: 'its governing pen trails drawn within' translated!
- menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu!
Item was changed:
----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') -----
addPenTrailsMenuItemsTo: aMenu
"Add items relating to pen trails to aMenu"
| oldTarget |
+ oldTarget _ aMenu defaultTarget.
- 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 addLine.
+ aMenu addUpdating: #batchPenTrailsString action: #toggleBatchPenTrails.
+ aMenu balloonTextForLastItem: 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.' translated.
+
aMenu defaultTarget: oldTarget!
Item was changed:
----- Method: PasteUpMorph>>addWorldToggleItemsToHaloMenu: (in category 'menu & halo') -----
addWorldToggleItemsToHaloMenu: aMenu
+ "Add toggle items for the world to the halo menu .... July 2009: no longer in world halo menu"
- "Add toggle items for the world to the halo menu"
+ "aMenu addUpdating: #showTabsString
+ target: CurrentProjectRefactoring
+ action: #currentToggleFlapsSuppressed "!
- #(
- (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 changed:
----- 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.
+ self changed "redraw"
- self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
!
Item was changed:
----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') -----
chooseClickTarget
Cursor crossHair showWhile:
[Sensor waitButton].
Cursor down showWhile:
[Sensor anyButtonPressed].
+ ^ (self morphsAt: Sensor cursorPoint) first topRendererOrSelf!
- ^ (self morphsAt: Sensor cursorPoint) first!
Item was changed:
----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') -----
correspondingFlapTab
+ "If there is a flap tab whose referent is me, return it, else return nil. Will also work for flaps on the edge of embedded subareas such as within scripting-areas, but more slowly."
+
- "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]].
+
+ "Catch guys in embedded worldlets"
+ ActiveWorld allMorphs do:
+ [:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]].
+
^ nil!
Item was changed:
----- 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' translatedNoop]!
- ['world']!
Item was changed:
----- 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@0) anyShapeFill reverse.
+ screenForm _ Form fromDisplay: (topLeft extent: outline extent).
- outline := poly shadowForm.
- topLeft := outline offset.
- exterior := (outline offset: 0@0) anyShapeFill reverse.
- screenForm := Form fromDisplay: (topLeft extent: outline extent).
screenForm eraseShape: exterior.
+ innerForm _ screenForm trimBordersOfColor: Color transparent.
+ ActiveHand showTemporaryCursor: nil.
- innerForm := screenForm trimBordersOfColor: Color transparent.
innerForm isAllWhite ifFalse:
[hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was changed:
----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
flapTab
+ "Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'"
+
| ww |
self isFlap ifFalse:[^nil].
+ ww _ self presenter associatedMorph ifNil: [ActiveWorld].
+ ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]!
- ww := self world ifNil: [World].
- ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]!
Item was changed:
----- 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>'])
+ , 'grid visible when gridding' translated!
- , 'show grid when gridding' translated!
Item was changed:
----- Method: PasteUpMorph>>installFlaps (in category 'world state') -----
installFlaps
"Get flaps installed within the bounds of the receiver"
+ | localFlapTabs |
Project current assureFlapIntegrity.
self addGlobalFlaps.
+ localFlapTabs := self localFlapTabs.
+ localFlapTabs do: [:each | each visible: false].
+
+ Preferences eToyFriendly ifTrue: [
+ ProgressInitiationException display: 'Building Viewers...' translated
+ during: [:bar |
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld.
+ bar value: i / self localFlapTabs size]].
+ ] ifFalse: [
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld]].
+
- self localFlapTabs do:
- [:aFlapTab | aFlapTab adaptToWorld].
self assureFlapTabsFitOnScreen.
self bringTopmostsToFront!
Item was changed:
----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') -----
presentCardAndStackMenu
"Put up a menu holding card/stack-related options."
| aMenu |
+ aMenu _ MenuMorph new defaultTarget: self.
- aMenu := MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
+ aMenu addTitle: 'card and stack' translated.
+ aMenu add: 'add new card' translated action: #insertCard.
+ aMenu add: 'delete this card' translated action: #deleteCard.
+ aMenu add: 'go to next card' translated action: #goToNextCardInStack.
+ aMenu add: 'go to previous card' translated action: #goToPreviousCardInStack.
- 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' translated action: #showForegroundObjects.
+ aMenu add: 'show background objects' translated action: #showBackgroundObjects.
+ aMenu add: 'show designations' translated action: #showDesignationsOfObjects.
+ aMenu add: 'explain designations' translated action: #explainDesignations.
- 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 changed:
----- Method: PasteUpMorph>>referencePool (in category 'objects from disk') -----
referencePool
^ self
valueOfProperty: #References
+ ifAbsentPut: [WeakValueDictionary new]
+ !
- ifAbsentPut: [OrderedCollection new]
-
- !
Item was changed:
----- 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 changed:
----- 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]!
- aPlayer startRunning; step; stopRunning].
-
- self allScriptors do:
- [:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
- !
Item was changed:
----- 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 stopSound.
+ aPlayer stopRunning].
- aPlayer stopRunning].
- self allScriptors do:
- [:aScript | aScript pauseIfTicking].
self world updateStatusForAllScriptEditors!
Item was changed:
----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') -----
triggerClosingScripts
"If the receiver has any scripts set to run on closing, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllClosingScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllClosingScripts]!
Item was changed:
----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') -----
triggerOpeningScripts
"If the receiver has any scripts set to run on opening, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllOpeningScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllOpeningScripts]!
Item was changed:
----- 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:
+ [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]!
- [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 changed:
----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
setTextColor: aColor
"Set the color of my text to the given color"
+ textMorph textColor: aColor!
- textMorph color: aColor!
Item was changed:
----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Polygon' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ 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.' translatedNoop!
- ^ 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 changed:
----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu 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."
+
- addCustomMenuItems: aMenu hand: aHandMorph
- | |
super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles.
+ vertices size > 2 ifTrue:
+ [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed].
+
+ aMenu addUpdating: #smoothPhrase target: self action: #toggleSmoothing.
+ aMenu addLine.
+ aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
+
+ self isOpen ifTrue:
+ [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]].!
- 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 changed:
----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
+
+ ^ Color black
+
+ "Until September 2007, this had long been...
^ Color
r: 0.0
g: 0.419
+ b: 0.935"!
- b: 0.935!
Item was changed:
----- Method: PolygonMorph>>fillStyle (in category 'visual properties') -----
fillStyle
+ "Answer the receiver's fillStyle. For an *open* polygon, we return the borderColor, provided it's a true color rather than something strange like the symbol #raised."
+ | aColor |
self isOpen
+ ifTrue:
+ [(aColor := self borderColor) isColor ifTrue: [^ aColor]]. "easy access to line color from halo -- di's old note"
+
+ ^ super fillStyle!
- ifTrue: [^ self borderColor "easy access to line color from halo"]
- ifFalse: [^ super fillStyle]!
Item was changed:
----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') -----
handlesShowingPhrase
+ "Answer a phrase characterizing whether handles are showing or not."
+
+ ^ (self showingHandles ifTrue: ['<yes>'] ifFalse: ['<no>']), ('show handles' translated)!
- ^ (self showingHandles
- ifTrue: ['hide handles']
- ifFalse: ['show handles']) translated!
Item was changed:
----- Method: PolygonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
+ "Handle a mouse-down event."
+ ^ (evt shiftPressed and: [(self hasProperty: #activateOnShift) not])
- ^ 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 changed:
----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') -----
openOrClosePhrase
+ "Answer a string indicating whether the receiver is open or closed."
+
+ ^ (closed ifTrue: ['<yes>'] ifFalse: ['<no>']), 'closed' translated!
- | 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 changed:
----- Method: PolygonMorph>>stepTime (in category 'testing') -----
stepTime
+ "Answer the desired time between steps in milliseconds."
+ ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [100]
+
+ "NB: in all currently known cases, polygons are not actually wrapped in TransformationMorphs, so the #topRendererOrSelf call above is probably redundant, but is retained for safety."!
- ^ 100!
Item was changed:
----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') -----
+ verticesAt: anInteger put: aPoint
+
+ self vertices at: anInteger put: aPoint asFloatPoint.
- verticesAt: ix put: newPoint
- vertices at: ix put: newPoint.
self computeBounds!
Item was changed:
----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') -----
allCurrentlyTickingScriptInstantiations
+ "Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking."
+
+ ^ Array streamContents:
+ [:aStream |
+ self allExtantPlayers do:
+ [:aPlayer | aPlayer instantiatedUserScriptsDo:
+ [:aScriptInstantiation |
+ aScriptInstantiation status == #ticking ifTrue:
+ [aStream nextPut: aScriptInstantiation]]]]!
- ^#()!
Item was changed:
----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') -----
+ browseAllScriptsTextually
+ "Open a method-list browser on all the scripts in the project"
+
+ | aList aMethodList |
+ self flushPlayerListCache. "Just to be certain we get everything"
+
+ (aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players' translated].
+ aMethodList _ OrderedCollection new.
+ aList do:
+ [:aPair | aPair first addMethodReferencesTo: aMethodList].
+ aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!' translated].
+
+ SystemNavigation new
+ browseMessageList: aMethodList
+ name: 'All scripts in this project'
+ autoSelect: nil
+
+ "
+ ActiveWorld presenter browseAllScriptsTextually
+ "!
- browseAllScriptsTextually!
Item was changed:
----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'ProjectView' translatedNoop!
- ^ 'ProjectView'!
Item was changed:
----- 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' translatedNoop
- label: 'load as project'
selector: #openFromDirectoryAndFileName:
+ description: 'open project from file' translatedNoop
+ buttonLabel: 'load' translatedNoop
- description: 'open project from file'
- buttonLabel: 'load'
)
argumentGetter: [ :fileList | fileList dirAndFileName]!
Item was changed:
----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
+ "Accept -- in a custom sense here -- a morph dropped on the receiver."
| 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 dropEnabled ifFalse:
+ [^ 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.
- 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 changed:
----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
dismissViaHalo
+ "The user clicked on the dismiss icon on the halo."
+
| choice |
+ project ifNil: [^ self delete]. "no current project"
+ choice := (PopUpMenu labelArray:{
+ 'yes - delete icon and remove the project' translated.
+ 'no - delete icon but keep the project' translated.
+ 'cancel - do not delete anything' translated.
+ }) startUpWithCaption: ('Do you really want to delete the
+ project named {1}
+ and all its contents?' translated format: {project name printString}).
+ choice = 1 ifTrue: [^ self expungeProject].
+ choice = 2 ifTrue: [^ self delete]!
- 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 changed:
----- 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' translated
- ^self inform: 'The project is not present and may not be renamed now'
].
self addProjectNameMorph launchMiniEditor: evt.!
Item was changed:
----- 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' translated]].
- 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 changed:
----- Method: ProjectViewMorph>>fontForName (in category 'drawing') -----
fontForName
+ ^(TextStyle default fontOfSize: 15) emphasized: 1
- | 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 changed:
----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver."
+
super initialize.
+ "currentBorderColor _ Color gray."
+ self addProjectNameMorphFiller.
+ self enableDragNDrop: true.
+ self isOpaque: true.
+ !
- "currentBorderColor := Color gray."
- self addProjectNameMorphFiller.!
Item was changed:
----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
+ "Answer if the receiver would accept a drop of a given morph."
+ "If drop-enabled not set, answer false"
+ (super wantsDroppedMorph: aMorph event: evt) ifFalse: [^ false].
+
+ "If project not present, not morphic, or not initialized, answer false"
+ self isTheRealProjectPresent ifFalse: [^ false].
+ project isMorphic ifFalse: [^ false].
+ project world viewBox ifNil: [^ false].
+
+ ^ true!
- self isTheRealProjectPresent ifFalse: [^false].
- project isMorphic ifFalse: [^false].
- project world viewBox ifNil: [^false]. "uninitialized"
- ^true!
Item was changed:
----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Rectangle' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'A rectangular shape, with border and fill style' translatedNoop!
- ^ self partName: 'Rectangle'
- categories: #('Graphics' 'Basic')
- documentation: 'A rectangular shape, with border and fill style'!
Item was changed:
----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') -----
roundRectPrototype
+ "Answer a prototypical RoundRect object for a parts bin."
+
^ self authoringPrototype useRoundedCorners
+ color: (Color r: 1.0 g: 0.3 b: 0.6);
- color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5);
borderWidth: 1;
setNameTo: 'RoundRect'!
Item was changed:
----- 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].
+ (self valueOfProperty: #withMenuButton) == false ifTrue: [^ nil].
+ menu _ MenuMorph new defaultTarget: model.
+ aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
- menu := MenuMorph new defaultTarget: model.
- aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
getMenuSelector numArgs = 1 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu.
- [aMenu := model perform: getMenuSelector with: menu.
aTitle ifNotNil: [aMenu addTitle: aTitle].
^ aMenu].
getMenuSelector numArgs = 2 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
- [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 changed:
----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Selection' translatedNoop!
- ^ 'Selection'!
Item was changed:
----- 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}.
+ #-.
+ {'distribute vertically' translated. #distributeVertically}.
+ {'distribute horizontally' translated. #distributeHorizontally}.
+ }
- }.
+
- self selectedItems size > 2
- ifTrue:[
- aMenu addList: {
- #-.
- {'distribute vertically' translated. #distributeVertically}.
- {'distribute horizontally' translated. #distributeHorizontally}.
- }.
- ].
!
Item was changed:
----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
+ selectedItems do: [:m | m dismissViaHalo].
-
super dismissViaHalo.
+ !
- selectedItems do: [:m | m dismissViaHalo]!
Item was changed:
----- Method: SelectionMorph>>extent: (in category 'geometry') -----
extent: newExtent
+ "Set the receiver's extent Extend or contract the receiver's selection to encompass morphs within the new extent."
super extent: newExtent.
+ self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])!
- self selectSubmorphsOf: self pasteUpMorph!
Item was changed:
----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: evt
+ "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
selectedItems isEmpty ifTrue:
["Hand just clicked down to draw out a new selection"
^ self extendByHand: evt hand].
+ dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
- 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)] fixTemps].
+ selectedItems _ nil.
+ self removeHalo.
+ self halo ifNotNil: [self halo visible: false].
+ self delete.
- (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
evt wasHandled: true!
Item was changed:
----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') -----
selectSubmorphsOf: aMorph
+ "Given the receiver's current bounds, select submorphs of the indicated pasteup morph that fall entirely within those bounds. If nobody is within the bounds, delete the receiver."
| newItems removals |
+ newItems _ aMorph submorphs select:
- newItems := aMorph submorphs select:
[:m | (bounds containsRect: m fullBounds)
and: [m~~self
and: [(m isKindOf: HaloMorph) not]]].
+ otherSelection ifNil: [^ selectedItems _ newItems].
- otherSelection ifNil: [^ selectedItems := newItems].
+ removals _ newItems intersection: itemsAlreadySelected.
- removals := newItems intersection: itemsAlreadySelected.
otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
+ selectedItems _ (newItems copyWithoutAll: removals).
+ selectedItems ifEmpty: [self delete]
- selectedItems := (newItems copyWithoutAll: removals).
!
Item was changed:
----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') -----
slideToTrash: evt
self delete.
+ "selectedItems do: [:m | m slideToTrash: evt]"!
- selectedItems do: [:m | m slideToTrash: evt]!
Item was changed:
----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
hasContentsInExplorer
+ ^self notEmpty!
- ^self isEmpty not!
Item was changed:
----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
^ self = SimpleButtonMorph
+ ifTrue: ['Button' translatedNoop]
- ifTrue: ['Button']
ifFalse: [^ super defaultNameStemForInstances]!
Item was changed:
----- 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 action selector' translated action: #setActionSelector.
aCustomMenu add: 'change arguments' translated action: #setArguments.
aCustomMenu add: 'change when to act' translated action: #setActWhen.
+ aCustomMenu add: 'set target' translated action: #sightTargets:.
+ target ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]].
- self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
!
Item was changed:
----- 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:
+ [target perform: actionSelector withArguments: arguments].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments]].
actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]!
Item was changed:
----- 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."
+ ^ super 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.
+ Feb 2007: It seems unlikely that Squeak Pages will be used in the OLPC image. Don't use this code. Consider removing all code that supports SqueakPages."
+ "
| bb thatPage um stem ind sqPg |
(actionSelector == #goToPageMorph:fromBookmark:) |
(actionSelector == #goToPageMorph:) ifFalse: [
+ ^ super objectForDataStream: refStrm]. 'normal case'.
- ^ super objectForDataStream: refStrm]. "normal case"
+ target url ifNil: ['Later force target book to get a url.'.
+ bb _ SimpleButtonMorph new. 'write out a dummy'.
- 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.
- (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.
- 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.
- 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'.
- 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
+ "!
- ^ um!
Item was changed:
----- Method: SimpleButtonMorph>>updateVisualState: (in category 'visual properties') -----
updateVisualState: evt
oldColor ifNotNil: [
self color:
((self containsPoint: evt cursorPoint)
+ ifTrue: [oldColor mixed: 0.5 with: Color white]
- ifTrue: [oldColor mixed: 1/2 with: Color white]
ifFalse: [oldColor])]
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ self setProperty: #autoExpand toValue: false.
self
on: #mouseMove
send: #mouseStillDown:onItem:
to: self!
Item was changed:
----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Sketch' translatedNoop!
- ^ 'Sketch'!
Item was changed:
----- Method: SketchMorph>>addToggleItemsToHaloMenu: (in category 'menus') -----
addToggleItemsToHaloMenu: aCustomMenu
+ "Add toggle-items to the halo menu"
+
- "Add toggle-items to the halo menu"
super addToggleItemsToHaloMenu: aCustomMenu.
+ (Smalltalk includesKey: #B3DRenderEngine) ifTrue: [
+ aCustomMenu addUpdating: #useInterpolationString target: self action: #toggleInterpolation.
+ ].
+ !
- Preferences noviceMode
- ifFalse: [""aCustomMenu
- addUpdating: #useInterpolationString
- target: self
- action: #toggleInterpolation]!
Item was changed:
----- Method: SketchMorph>>collapse (in category 'menus') -----
collapse
+ "Replace the receiver with a collapsed rendition of itself."
-
- | priorPosition w collapsedVersion a |
+ | w collapsedVersion a ht tab |
+
+ (w _ self world) ifNil: [^self].
+ collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
- (w := self world) ifNil: [^self].
- collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph.
collapsedVersion setProperty: #uncollapsedMorph toValue: self.
collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
+
+ collapsedVersion setBalloonText: ('A collapsed version of {1}. Click to open it back up.' translated format: {self externalName}).
+
- collapsedVersion setBalloonText: 'A collapsed version of ',self name.
-
self delete.
w addMorphFront: (
+ a _ AlignmentMorph newRow
- a := AlignmentMorph newRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 4;
borderColor: Color white;
+ addMorph: collapsedVersion;
+ yourself).
+ a setNameTo: self externalName.
+ ht := (tab := Smalltalk at: #SugarNavTab ifPresent: [:c | ActiveWorld findA: c])
+ ifNotNil:
+ [tab height]
+ ifNil:
+ [80].
+ a position: 0@ht.
+
- addMorph: collapsedVersion
- ).
collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+ (self valueOfProperty: #collapsedPosition) ifNotNilDo:
+ [:priorPosition |
+ a position: priorPosition]!
- (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil])
- ifNotNil:
- [a position: priorPosition].
- !
Item was changed:
----- 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 x = 0 or: [newExtent y = 0]) ifTrue: [ ^self ].
- newExtent isZero ifTrue: [ ^self ].
self extent = newExtent ifTrue:[^self].
self scalePoint: newExtent asFloatPoint / (originalForm extent max: 1@1).
self layoutChanged.
!
Item was changed:
----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') -----
flipHorizontal
+ | r |
+ r _ self rotationCenter.
+ self left: self left - (1.0 - (2 * r x) * self width).
+ self form: (self form flipBy: #horizontal centerAt: self form center).
+ self rotationCenter: (1 - r x) @ (r y).!
- self form: (self form flipBy: #horizontal centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>flipVertical (in category 'e-toy support') -----
flipVertical
+ | r |
+ r _ self rotationCenter.
+ self top: self top - (1.0 - (2 * r y) * self height).
+ self form: (self form flipBy: #vertical centerAt: self form center).
+ self rotationCenter: r x @ (1 - r y).!
- self form: (self form flipBy: #vertical centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>initializeWith: (in category 'initialization') -----
initializeWith: aForm
super initialize.
+ originalForm _ aForm.
+ rotationStyle _ #normal. "styles: #normal, #leftRight, #upDown, or #none"
+ scalePoint _ 1.0(a)1.0.
+ framesToDwell _ 1.
+ rotatedForm _ originalForm. "cached rotation of originalForm"
- originalForm := aForm.
- self rotationCenter: 0.5(a)0.5. "relative to the top-left corner of the Form"
- rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none"
- scalePoint := 1.0(a)1.0.
- framesToDwell := 1.
- rotatedForm := originalForm. "cached rotation of originalForm"
self extent: originalForm extent.
!
Item was changed:
----- 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
+ Because my rendering code flips the form (see generateRotatedForm) we 'pre-flip' it here to preserve the same visual appearance.
+ "
- #none -- do not rotate"
+ | wasFlippedX wasFlippedY isFlippedX isFlippedY |
+ wasFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ wasFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ rotationStyle _ aSymbol.
+
+ isFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ isFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ wasFlippedX == isFlippedX
+ ifFalse: [self form: (self form flipBy: #horizontal centerAt: self form center)].
+ wasFlippedY == isFlippedY
+ ifFalse: [self form: (self form flipBy: #vertical centerAt: self form center)].
+
- rotationStyle := aSymbol.
self layoutChanged.
!
Item was changed:
----- Method: Slider>>sliderThickness (in category 'geometry') -----
sliderThickness
+ "^ 7"
+
+ | w |
+ w _ bounds isWide
+ ifTrue: [super height]
+ ifFalse: [super width].
+
+ ^ (w // 32) max: 16.
+ !
- ^ 7!
Item was changed:
----- 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: [FormDictionary at: #Cat]].
+ ^ FormDictionary at: #Cat!
- [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
- ^ nil!
Item was changed:
----- 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.
+ aCustomMenu addUpdating: #usePangoString target: self action: #toggleUsePango.
!
Item was changed:
----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
addOptionalHandlesTo: aHalo box: box
+ "eventually, add more handles for font..."
+
self flag: #deferred.
+ ^ super addOptionalHandlesTo: aHalo box: box
"Eventually...
self addFontHandlesTo: aHalo box: box"!
Item was changed:
----- 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 projectParameterAt: #substitutedFont).
+ (substituteFont notNil and: [self font == substituteFont])
- substituteFont := aProject projectParameters at:
- #substitutedFont ifAbsent: [#none].
- (substituteFont ~~ #none and: [self font == substituteFont])
ifTrue: [ self fitContents ].
^ super fixUponLoad: aProject seg: anImageSegment!
Item was changed:
----- Method: StringMorph>>font: (in category 'printing') -----
font: aFont
"Set the font my text will use. The emphasis remains unchanged."
+ aFont = font ifTrue: [^ self].
+ font _ aFont.
- font := aFont.
^ self font: font emphasis: emphasis!
Item was changed:
----- Method: StringMorphEditor>>initialize (in category 'display') -----
initialize
"Initialize the receiver. Give it a white background"
super initialize.
self backgroundColor: Color white.
+ self textColor: Color red.!
- self color: Color red!
Item was changed:
----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'TrueType banner' translatedNoop
+ categories: #()
+ documentation: 'A short text in a beautiful font. Use the resize handle to change size.' translatedNoop!
- ^ self partName: 'TrueType banner'
- categories: #('Demo')
- documentation: 'A short text in a beautiful font. Use the resize handle to change size.'!
Item was changed:
----- 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' translatedNoop. 'A scrolling data field which will have a different value on every card of the background' translatedNoop}
- 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 changed:
----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') -----
borderedPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t fontName: 'BitstreamVeraSans' pointSize: 24.
t autoFit: false; extent: 250@100.
+ t borderWidth: 1; margins: 4@0; backgroundColor: Color white.
- t borderWidth: 1; margins: 4@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 changed:
----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Text' translatedNoop!
- ^ 'Text'!
Item was changed:
----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') -----
fancyPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t autoFit: false; extent: 150@75.
t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?"
"fancy font, shadow, rounded"
+ t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; fillStyle: Color lightBrown.
- 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 changed:
----- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- 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' translatedNoop. 'A piece of text that will occur on every card of the background' translatedNoop}
- 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' translatedNoop. 'A data field which will have a different value on every card of the background' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you wish' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish')
forFlapNamed: 'Stack Tools'.
+ cl registerQuad: {#TextMorph . #fancyPrototype. 'Fancy Text' translatedNoop. 'A text field with a rounded shadowed border, with a fancy font.' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
forFlapNamed: 'Supplies'.]!
Item was changed:
----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+ (self backgroundColor isNil or: [self backgroundColor asColor isTranslucent])
- (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 changed:
----- Method: TextMorph>>backgroundColor (in category 'accessing') -----
backgroundColor
+ ^ self fillStyle.
+ !
- ^ backgroundColor!
Item was changed:
----- Method: TextMorph>>backgroundColor: (in category 'accessing') -----
backgroundColor: newColor
+ self fillStyle: newColor.
+ !
- backgroundColor := newColor.
- self changed!
Item was changed:
----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
beAllFont: aFont
+ textStyle _ TextStyle fontArray: (Array with: aFont).
+ text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)].
- textStyle := TextStyle fontArray: (Array with: aFont).
self releaseCachedState; changed!
Item was changed:
----- Method: TextMorph>>defaultLineHeight (in category 'geometry') -----
defaultLineHeight
+ ^ ( textStyle fontAt: textStyle defaultFontIndex) pointSize!
- ^ textStyle lineGrid!
Item was changed:
----- 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 wid |
- | newExtent para cBounds lastOfLines heightOfLast |
self isAutoFit
ifTrue:
+ [wid _ (text notNil and: [text size > 2]) ifTrue: [5] ifFalse: [40].
+ newExtent := (self paragraph extent max: wid @ ( self defaultLineHeight)) + (0 @ 2).
- [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 changed:
----- Method: TextMorph>>insertCharacters: (in category 'scripting access') -----
+ insertCharacters: aString
- insertCharacters: aSource
"Insert the characters from the given source at my current cursor position"
+ | aLoc aText attributes |
- | aLoc |
aLoc := self cursor max: 1.
+ aText := aLoc > text size
+ ifTrue: [aString asText]
+ ifFalse: [
+ attributes := (text attributesAt: aLoc)
+ select: [:attr | attr mayBeExtended].
+ Text string: aString attributes: attributes].
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aText displaying: true.
- paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
self updateFromParagraph !
Item was changed:
----- 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].
- [paragraph := nil].
container ifNotNil:
+ [container isMorph ifTrue: [container releaseCachedState]]!
- [container releaseCachedState]!
Item was changed:
----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') -----
setAllButFirstCharacter: source
"Set all but the first char of the receiver to the source"
+ | chars |
+ (chars _ self getCharacters) isEmpty
- | aChar chars |
- aChar := source asCharacter.
- (chars := self getCharacters) isEmpty
ifTrue: [self newContents: 'ยท' , source asString]
+ ifFalse: [self newContents: (String
- ifFalse: [chars first = aChar
- ifFalse: [""
- self
- newContents: (String
streamContents: [:aStream |
aStream nextPut: chars first.
+ aStream nextPutAll: source])]!
- aStream nextPutAll: source])]] !
Item was changed:
----- Method: TextMorph>>textColor: (in category 'accessing') -----
textColor: aColor
+ self editor selectFrom: 1 to: 0.
+ self selectionColor: aColor.
- color = aColor ifTrue: [^ self].
- color := aColor.
- self changed.
!
Item was changed:
----- Method: TheWorldMenu>>remoteMenu (in category 'construction') -----
remoteMenu
"Build the Telemorphic menu for the world."
+ ^self fillIn: (self menu: 'Telemorphic' translatedNoop) from: {
+ { 'local host address' translatedNoop. { #myWorld . #reportLocalAddress } }.
+ { 'connect remote user' translatedNoop. { #myWorld . #connectRemoteUser } }.
+ { 'disconnect remote user' translatedNoop. { #myWorld . #disconnectRemoteUser } }.
+ { 'disconnect all remote users' translatedNoop. { #myWorld . #disconnectAllRemoteUsers } }.
- ^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 changed:
----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') -----
windowsMenu
"Build the windows menu for the world."
+ ^ self fillIn: (self menu: 'windows' translatedNoop) from: {
+ { 'find window' translatedNoop. { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' translatedNoop}.
- ^ 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...' translatedNoop. { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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...' translatedNoop. { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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.' translatedNoop}.
- tile: new windows positioned so that they do not overlap others, if possible.'}.
nil.
+ { 'collapse all windows' translatedNoop. { #myWorld . #collapseAllWindows }. 'Reduce all open windows to collapsed forms that only show titles.' translatedNoop}.
+ { 'collapse all objects' translatedNoop. { #myWorld . #collapseAllWindowsAndNonWindows }. 'Reduce all open windows and all other objects on the desktop to labeled tabs' translatedNoop}.
+ { 'expand all' translatedNoop. { #myWorld . #expandAllCollapsedObjects }. 'Expand all collapsed windows and other collapsed objects back to their expanded forms.' translatedNoop}.
+
+ { 'close top window (w)' translatedNoop. { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.' translatedNoop}.
+ { 'send top window to back (\)' translatedNoop. { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.' translatedNoop}.
+ { 'move windows onscreen' translatedNoop. { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen' translatedNoop}.
- { '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' translatedNoop. { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.' translatedNoop}.
+ { 'delete non-windows' translatedNoop. { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.' translatedNoop}.
+ { 'delete both of the above' translatedNoop. { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' translatedNoop}.
- { '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 changed:
----- 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."
+ | args |
(target notNil and: [actionSelector notNil])
ifTrue:
+ [args := actionSelector numArgs > arguments size
+ ifTrue:
+ [arguments copyWith: ActiveEvent]
+ ifFalse:
+ [arguments].
+ Cursor normal
+ showWhile: [target perform: actionSelector withArguments: args].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments].
target isMorph ifTrue: [target changed]]!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| now dt |
- self state: #pressed.
actWhen == #buttonDown
+ ifTrue: [self doButtonAction].
+ actWhen == #buttonUp
+ ifTrue: [self state: #pressed].
+ actWhen == #whilePressed
+ ifTrue:
+ [self state: #pressed.
+ now _ Time millisecondClockValue.
- 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"
+ "NOTE: this delay is temporary disabled because it makes event reaction delay,
+ e.g. the action is not stopped even if you release the button... - Takashi"
+ [dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
+ self mouseStillDown: evt].
+ super mouseDown: evt!
- dt := Time millisecondClockValue - now max: 0. "Time it took to do"
- dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
- self mouseStillDown: evt.!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ (#(#buttonUp #whilePressed ) includes: actWhen)
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #pressed]
+ ifFalse: [self state: #off]].
+ super mouseMove: evt!
- 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 changed:
----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
- mouseUp: evt
"Allow on:send:to: to set the response to events other than actWhen"
+ actWhen == #buttonDown
+ ifTrue: [super mouseUp: evt].
+ actWhen == #buttonUp
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #on.
+ self doButtonAction: evt.
+ super mouseUp: evt]
+ ifFalse: [self state: #off.
+ target
+ ifNotNil: ["Allow owner to keep it selected for radio
+ buttons"
+ target mouseUpBalk: evt]]].
+ actWhen == #whilePressed
+ ifTrue: [self state: #off.
+ super mouseUp: evt]!
- 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 changed:
----- 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: [1]
- ifTrue: [ 2]
ifFalse: [1]!
Item was changed:
----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') -----
fitContents
+ | newExtent |
+ newExtent := self measureContents.
+ newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.
- | 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 changed:
----- Method: UpdatingStringMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver to have default values in its instance variables."
- "Initialie the receiver to have default values in its instance
- variables "
super initialize.
""
+ format _ #default.
- format := #default.
"formats: #string, #default"
+ target _ getSelector _ putSelector _ nil.
+ floatPrecision _ 1.
+ growable _ true.
+ stepTime _ nil.
+ autoAcceptOnFocusLoss _ true.
+ minimumWidth _ 8.
+ maximumWidth _ 366!
- target := getSelector := putSelector := nil.
- floatPrecision := 1.
- growable := true.
- stepTime := 50.
- autoAcceptOnFocusLoss := true.
- minimumWidth := 8.
- maximumWidth := 300!
Item was changed:
----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') -----
readFromTarget
"Update my readout from my target"
+ | v ret places |
- | v ret |
(target isNil or: [getSelector isNil]) ifTrue: [^contents].
+ ret _ self checkTarget.
- ret := self checkTarget.
ret ifFalse: [^ '0'].
+ ((target isMorph) or:[target isPlayerLike]) ifTrue:[
+ places _ target decimalPlacesForGetter: getSelector.
+ (places ~= nil and: [ places ~= (self valueOfProperty: #decimalPlaces ifAbsent: [0])]) ifTrue: [ self decimalPlaces: places ]].
v := target perform: getSelector. "scriptPerformer"
(v isKindOf: Text) ifTrue: [v := v asString].
^self acceptValueFromTarget: v!
Item was changed:
----- 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 := MenuMorph new.
aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
+ 0 to: 10 do:
- 0 to: 5 do:
[:places |
aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
aMenu popUpInWorld!
Item was changed:
----- Method: UpdatingStringMorph>>stepTime (in category 'testing') -----
stepTime
+ ^ stepTime ifNil: [200]
- ^ stepTime ifNil: [50]
!
Item was changed:
----- 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.
+ self setProperty: #decimalPlaces toValue: ((self valueOfProperty: #decimalPlaces ifAbsent: [0]) veryDeepCopyWith: 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.
!
1
0
Tim Felgentreff uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-tfel.1288.mcz
==================== Summary ====================
Name: Morphic-tfel.1288
Author: tfel
Time: 21 August 2016, 4:45:44.253391 pm
UUID: 18a05809-bd60-4baa-a764-11dc7f13d82f
Ancestors: Morphic-mt.1287, Morphic-tfel.1250
merge trunk
=============== Diff against Morphic-mt.1287 ===============
Item was changed:
----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') -----
supplementaryPartsDescriptions
"Extra items for parts bins"
^ {DescriptionForPartsBin
+ formalName: 'Circle' translatedNoop
+ categoryList: {'Graphics' translatedNoop}
+ documentation: 'A circular shape' translatedNoop
- formalName: 'Circle1'
- categoryList: #('Graphics')
- documentation: 'A circular shape'
globalReceiverSymbol: #CircleMorph
nativitySelector: #newStandAlone.
+ DescriptionForPartsBin
+ formalName: 'Pin' translatedNoop
+ categoryList: {'Connectors' translatedNoop}
+ documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop
- "DescriptionForPartsBin
- formalName: 'Pin'
- categoryList: #('Connectors')
- documentation: 'An attachment point for Connectors that you can embed in another Morph.'
globalReceiverSymbol: #NCPinMorph
+ nativitySelector: #newPin.
- nativitySelector: #newPin."
}!
Item was changed:
SketchMorph subclass: #ColorPickerMorph
+ instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency noChart'
+ classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransparentBox TransText'
- 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 changed:
----- 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 @ 31. "<<<< the form was changed a bit??"
- 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 changed:
----- 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 insetBy: 2) fillColor: feedbackColor.
- originalForm fill: FeedbackBox fillColor: feedbackColor.
self form: originalForm.
+ selectedColor _ aColor.
- selectedColor := aColor.
updateContinuously ifTrue: [self updateTargetColor].
self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).!
Item was changed:
----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Ellipse' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'An elliptical or circular shape' translatedNoop!
- ^ self partName: 'Ellipse'
- categories: #('Graphics' 'Basic')
- documentation: 'An elliptical or circular shape'!
Item was changed:
----- Method: HaloMorph>>addDupHandle: (in category 'handles') -----
addDupHandle: haloSpec
"Add the halo that offers duplication, or, when shift is down, make-sibling"
+ | aSelector |
+ aSelector := innerTarget couldMakeSibling
+ ifTrue:
+ [#doDupOrMakeSibling:with:]
+ ifFalse:
+ [#doDup:with:].
- self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self
+ self addHandle: haloSpec on: #mouseDown send: aSelector to: self
+
!
Item was changed:
----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') -----
addHandlesForWorldHalos
"Add handles for world halos, like the man said"
| box w |
+ w _ self world ifNil:[target world].
- w := self world ifNil:[target world].
self removeAllMorphs. "remove old handles, if any"
self bounds: target bounds.
+ box _ w bounds insetBy: self handleSize // 2.
- box := w bounds insetBy: 9.
target addWorldHandlesTo: self box: box.
Preferences uniqueNamesInHalos ifTrue:
[innerTarget assureExternalName].
self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
+ growingOrRotating _ false.
- growingOrRotating := false.
self layoutChanged.
self changed.
!
Item was changed:
----- Method: HaloMorph>>addViewingHandle: (in category 'handles') -----
addViewingHandle: haloSpec
+ "If appropriate, add a special Viewing halo handle to the receiver. On 26 Sept 07, we decided to eliminate this item from the UI, so the code of is method is now commented out...
- "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 changed:
----- Method: HaloMorph>>basicBox (in category 'private') -----
basicBox
| aBox minSide anExtent w |
+ minSide _ 4 * self handleSize.
+ anExtent _ ((self width + self handleSize + 8) max: minSide) @
- 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].
- aBox := Rectangle center: self center extent: anExtent.
- w := self world ifNil:[target outermostWorldMorph].
^ w
ifNil:
[aBox]
ifNotNil:
+ [aBox intersect: (w viewBox insetBy: self handleSize // 2)]
- [aBox intersect: (w viewBox insetBy: 8@8)]
!
Item was changed:
----- Method: HaloMorph>>doDirection:with: (in category 'private') -----
doDirection: anEvent with: directionHandle
+ "The mouse went down on the forward-direction halo handle; respond appropriately."
+
anEvent hand obtainHalo: self.
+ anEvent shiftPressed
+ ifTrue:
+ [directionArrowAnchor _ (target point: target referencePosition in: self world) rounded.
+ self positionDirectionShaft: directionHandle.
+ self removeAllHandlesBut: directionHandle.
+ directionHandle setProperty: #trackDirectionArrow toValue: true]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: directionHandle]!
- self removeAllHandlesBut: directionHandle!
Item was changed:
----- Method: HaloMorph>>handleSize (in category 'private') -----
handleSize
^ Preferences biggerHandles
+ ifTrue: [30]
- ifTrue: [20]
ifFalse: [16]!
Item was changed:
----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') -----
prepareToTrackCenterOfRotation: evt with: rotationHandle
+ "The mouse went down on the center of rotation."
+
evt hand obtainHalo: self.
+ evt shiftPressed
+ ifTrue:
+ [self removeAllHandlesBut: rotationHandle.
+ rotationHandle setProperty: #trackCenterOfRotation toValue: true.
+ evt hand showTemporaryCursor: Cursor blank]
+ ifFalse:
+ [ActiveHand spawnBalloonFor: rotationHandle]!
- evt shiftPressed ifTrue:[
- self removeAllHandlesBut: rotationHandle.
- ] ifFalse:[
- rotationHandle setProperty: #dragByCenterOfRotation toValue: true.
- self startDrag: evt with: rotationHandle
- ].
- evt hand showTemporaryCursor: Cursor blank!
Item was changed:
----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') -----
setCenterOfRotation: evt with: rotationHandle
| localPt |
evt hand obtainHalo: self.
evt hand showTemporaryCursor: nil.
+ (rotationHandle hasProperty: #trackCenterOfRotation) ifTrue:
+ [localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
+ innerTarget setRotationCenterFrom: localPt].
+
+ rotationHandle removeProperty: #trackCenterOfRotation.
+ self endInteraction!
- (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[
- localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
- innerTarget setRotationCenterFrom: localPt.
- ].
- rotationHandle removeProperty: #dragByCenterOfRotation.
- self endInteraction
- !
Item was changed:
----- 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"
+ (directionHandle hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ target setDirectionFrom: directionHandle center.
+ directionHandle removeProperty: #trackDirectionArrow.
+ self endInteraction]!
- anEvent hand obtainHalo: self.
- target setDirectionFrom: directionHandle center.
- self endInteraction!
Item was changed:
----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') -----
trackCenterOfRotation: anEvent with: rotationHandle
(rotationHandle hasProperty: #dragByCenterOfRotation)
ifTrue:[^self doDrag: anEvent with: rotationHandle].
+ (rotationHandle hasProperty: #trackCenterOfRotation)
+ ifTrue:
+ [anEvent hand obtainHalo: self.
+ rotationHandle center: anEvent cursorPoint]!
- anEvent hand obtainHalo: self.
- rotationHandle center: anEvent cursorPoint.!
Item was changed:
----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') -----
trackDirectionArrow: anEvent with: shaft
+ (shaft hasProperty: #trackDirectionArrow) ifTrue:
+ [anEvent hand obtainHalo: self.
+ shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
+ self layoutChanged]!
- anEvent hand obtainHalo: self.
- shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
- self layoutChanged!
Item was changed:
----- Method: HandleMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self extent: 16 @ 16.
- self extent: 8 @ 8.
!
Item was changed:
----- Method: IconicButton>>stationarySetup (in category 'initialization') -----
stationarySetup
+ "Set up event handlers for mouse actions. Should be spelled stationery..."
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.
+
+ self on: #click send: #launchPartFromClick to: self!
- self on: #mouseUp send: #borderThick to: self.!
Item was changed:
----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Image' translatedNoop
+ categories: #()
+ documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.' translatedNoop!
- ^ 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 changed:
----- 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' translatedNoop. 'A non-editable picture of something' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Joystick' translatedNoop
+ categories: {'Basic' translatedNoop}
+ documentation: 'A joystick-like control' translatedNoop!
- ^ self partName: 'Joystick'
- categories: #('Useful')
- documentation: 'A joystick-like control'!
Item was changed:
----- 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' translatedNoop. 'A joystick-like control' translatedNoop}
- ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'PlugIn Supplies'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Scripting'.
+ cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop}
- cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control')
forFlapNamed: 'Supplies']!
Item was changed:
----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ "Answer a description for the parts bin."
+
+ ^ self partName: 'Line' translatedNoop
+ categories: {'Graphics' translatedNoop}
+ documentation: 'A straight line. Shift-click to get handles and move the ends.' translatedNoop!
- ^ self partName: 'Line'
- categories: #('Graphics' 'Basic')
- documentation: 'A straight line. Shift-click to get handles and move the ends.'!
Item was changed:
----- 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.
- ActiveWorld addMorph: self centeredNear: aPoint.
self world displayWorld. "show myself"
+ aBlock value]
+ ensure: [self delete]!
- aBlock value.
- self delete!
Item was changed:
----- Method: MenuIcons class>>iconForMenuItem: (in category 'menu decoration') -----
iconForMenuItem: anItem
+ "Answer the icon (or nil) corresponding to a given menu item."
- "Answer the icon (or nil) corresponding to the (translated) string."
+ | aKey |
+ aKey _ (anItem selector == #undoOrRedoCommand)
+ ifTrue:
+ ['undo (z)' translated] "Actual wording changes dynamically"
+ ifFalse:
+ [anItem contents asString].
+ ^ TranslatedIcons at: aKey asLowercase ifAbsent: [nil]!
- ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]!
Item was changed:
----- Method: MenuMorph>>delete (in category 'initialization') -----
delete
+ "Delete the receiver."
+
+ activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]].
+ self isFlexed ifTrue: [^ owner delete].
+ ^ super delete!
- activeSubMenu ifNotNil:[activeSubMenu delete].
- ^super delete!
Item was changed:
----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') -----
serviceLoadMorphFromFile
"Answer a service for loading a .morph file"
^ SimpleServiceEntry
provider: self
+ label: 'load as morph' translatedNoop
- label: 'load as morph'
selector: #fromFileName:
+ description: 'load as morph' translatedNoop
+ buttonLabel: 'load' translatedNoop!
- description: 'load as morph'
- buttonLabel: 'load'!
Item was changed:
----- 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 w |
+ menu _ MenuMorph new defaultTarget: self.
+ w _ self world.
+ self potentialEmbeddingTargets reverseDo: [:m |
+ menu add: (m == w ifTrue: ['desktop' translated] ifFalse: [m knownName ifNil:[m class name asString]]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}.
+ m == self topRendererOrSelf owner ifTrue:
+ [menu lastItem color: Color red]].
+ aMenu ifNotNil:
+ [menu submorphCount > 0
+ ifTrue:[aMenu add:'embed into' translated subMenu: 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 changed:
----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') -----
addFlexShell
"Wrap a rotating and scaling shell around this morph."
+ | oldHalo flexMorph myWorld anIndex morphOwner |
- | oldHalo flexMorph myWorld anIndex |
myWorld := self world.
+ oldHalo:= self halo.
+ self owner ifNotNil:[ morphOwner := self owner]
+ ifNil:[morphOwner := self currentWorld].
+
+ anIndex := morphOwner submorphIndexOf: self.
+ morphOwner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self)
- 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 changed:
----- Method: Morph>>addHaloActionsTo: (in category 'menus') -----
addHaloActionsTo: aMenu
"Add items to aMenu representing actions requestable via halo"
| subMenu |
+ subMenu _ MenuMorph new defaultTarget: self.
- 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 add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles.
subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated.
+ subMenu add: 'tile representing this object' translated target: self action: #tearOffTile.
- 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 changed:
----- 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 notNil and: [aNumber <= submorphs size])
- (aNumber <= submorphs size)
ifTrue:
[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
ifFalse:
+ [self addMorphBack: aMorph]!
- [self addMorphBack: aMorph]
- !
Item was changed:
----- 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 and: [Preferences noviceMode not])
- 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 changed:
----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') -----
chooseNewGraphicCoexisting: aBoolean
"Allow the user to choose a different form for her form-based morph"
+
| replacee aGraphicalMenu |
+ self isInWorld ifFalse: "menu must have persisted for a not-in-world object."
+ [aGraphicalMenu := ActiveWorld submorphThat:
+ [:m | (m isKindOf: GraphicalMenu) and: [m target == self]]
+ ifNone:
+ [^ self].
+ ^ aGraphicalMenu show; flashBounds].
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 changed:
----- Method: Morph>>couldMakeSibling (in category 'testing') -----
couldMakeSibling
"Answer whether it is appropriate to ask the receiver to make a sibling"
+ ^ self isWorldMorph not!
- ^ true!
Item was changed:
----- Method: Morph>>goBehind (in category 'submorphs-add/remove') -----
goBehind
+ "Move the receiver to bottom z-order."
+ | topRend |
+ topRend := self topRendererOrSelf.
+ topRend owner ifNotNilDo:
+ [:own | own addMorphNearBack: topRend]
- owner addMorphNearBack: self.
!
Item was changed:
----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') -----
invokeMetaMenu: evt
+ "Put up the 'meta' menu, invoked via control-click, unless eToyFriendly is true."
+
| menu |
+ Preferences eToyFriendly ifTrue: [^ self].
+
+ menu _ self buildMetaMenu: evt.
- menu := self buildMetaMenu: evt.
menu addTitle: self externalName.
+ menu popUpEvent: evt in: self world!
- self world ifNotNil: [
- menu popUpEvent: evt in: self world
- ]!
Item was changed:
----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') -----
obtrudesBeyondContainer
"Answer whether the receiver obtrudes beyond the bounds of its container"
+ | top formerOwner |
- | top |
top := self topRendererOrSelf.
+ top owner ifNil: [^ false].
+ ^ top owner isHandMorph
+ ifTrue:
+ [((formerOwner := top formerOwner) notNil and: [formerOwner isInWorld])
+ ifFalse:
+ [false]
+ ifTrue:
+ [(formerOwner boundsInWorld containsRect: top boundsInWorld) not]]
+ ifFalse:
+ [(top owner bounds containsRect: top bounds) not]!
- (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false].
- ^(top owner bounds containsRect: top bounds) not!
Item was changed:
----- Method: Morph>>on:send:to: (in category 'event handling') -----
on: eventName send: selector to: recipient
+ "When the given event occurs, send the given selector to the given recipient. If the given selector is nil, rescind any earlier handling for the given event type,"
+
+ self eventHandler ifNil:
+ [selector ifNil: [^ self]. "Don't pointlessly create an event handler!!"
+ self eventHandler: EventHandler new].
- self eventHandler ifNil: [self eventHandler: EventHandler new].
self eventHandler on: eventName send: selector to: recipient!
Item was changed:
----- Method: Morph>>openViewerForArgument (in category 'player viewer') -----
openViewerForArgument
+ Cursor wait
+ showWhile: [self presenter viewMorph: self]!
- "Open up a viewer for a player associated with the morph in question. "
- self presenter viewMorph: self!
Item was changed:
----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') -----
overlapsShadowForm: itsShadow bounds: itsBounds
"Answer true if itsShadow and my shadow overlap at all"
+ | overlapExtent overlap myRect myShadow goalRect goalShadow bb |
+ overlap _ self fullBounds intersect: itsBounds.
+ overlapExtent _ overlap extent.
- | andForm overlapExtent |
- overlapExtent := (itsBounds intersect: self fullBounds) extent.
overlapExtent > (0 @ 0)
ifFalse: [^ false].
+ myRect := overlap translateBy: 0 @ 0 - self topLeft.
+ myShadow := (self imageForm contentsOfArea: myRect) stencil.
+ goalRect := overlap translateBy: 0 @ 0 - itsBounds topLeft.
+ goalShadow := (itsShadow contentsOfArea: goalRect) stencil.
+
+ "compute a pixel-by-pixel AND of the two stencils. Result will be black
+ (pixel value = 1) where black parts of the stencils overlap"
+ bb := BitBlt toForm: myShadow.
+ bb
+ copyForm: goalShadow
+ to: 0 @ 0
+ rule: Form and.
+
+ ^(bb destForm tallyPixelValues second) > 0 !
- 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 changed:
----- Method: Morph>>roundUpStrays (in category 'miscellaneous') -----
roundUpStrays
+ "Bring submorphs of playfieldlike structures in the receiver's interior back within view."
+
+ self submorphsDo:
+ [:m | m isPlayfieldLike ifTrue: [m roundUpStrays]]!
- self submorphs
- do: [:each | each roundUpStrays]!
Item was changed:
----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') -----
slideBackToFormerSituation: evt
+ "A drop of the receiver having been rejected, slide it back to where it came from, if possible."
+
| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
formerOwner := self formerOwner.
formerPosition := self formerPosition.
+ (aWorld := evt hand world) ifNil: [^ self delete]. "Likely a moribund hand from an EventRecorder playback."
+
- 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.
+ "The OLPC Virtual Screen wouldn't notice the last update here."
+ Display forceToScreen: (endPoint extent: slideForm extent).
formerOwner addMorph: self.
self position: formerPosition.
self justDroppedInto: formerOwner event: evt!
Item was changed:
----- Method: Morph>>useGradientFill (in category 'visual properties') -----
useGradientFill
"Make receiver use a solid fill style (e.g., a simple color)"
+
+ | fill color1 color2 fil |
+ ((fil := self fillStyle) notNil and: [fil isSymbol not] and: [fil isGradientFill]) ifTrue:[^self]. "Already done"
+ color1 _ self color asColor.
+ color2 _ color1 negated.
+ fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
- | 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 changed:
----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') -----
wantsHaloFromClick
+
+ ^ self valueOfProperty: #wantsHaloFromClick ifAbsent: [^true].!
- ^ true!
Item was added:
+ ----- Method: MorphicModel>>addModelYellowButtonMenuItemsTo:forMorph:hand: (in category 'graph model') -----
+ addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph
+
+ Preferences noviceMode ifFalse: [
+ super addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph].
+ ^ aCustomMenu!
Item was added:
+ ----- Method: MorphicProject>>exportSegmentInSexpWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') -----
+ exportSegmentInSexpWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: noInteraction
+
+ | fd sexp actualName |
+
+ world ifNil: [^ false].
+ world presenter ifNil: [^ false].
+ (world respondsTo: #sissScanObjectsAsEtoysProject) ifFalse: [^ false].
+
+ Command initialize.
+ world clearCommandHistory.
+ world cleanseStepList.
+ world localFlapTabs size = world flapTabs size ifFalse: [
+ noInteraction ifTrue: [^ false].
+ self error: 'Still holding onto Global flaps'].
+
+ fd _ aDirectory directoryNamed: self resourceDirectoryName.
+ fd assureExistence.
+
+ "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:[
+ sexp _ world sissScanObjectsAsEtoysProject.
+ ].
+ (aFileName endsWith: '.pr') ifTrue: [
+ actualName _ (aFileName copyFrom: 1 to: aFileName size - 3), '.sexp'.
+ ] ifFalse: [
+ actualName _ aFileName
+ ].
+
+ self
+ writeForExportInSexp: sexp withSources: actualName
+ inDirectory: fd
+ changeSet: aChangeSetOrNil.
+ SecurityManager default signFile: actualName directory: fd.
+ self storeHtmlPageIn: fd.
+ (world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new])
+ at: 'Project-Format' put: 'S-Expression'.
+ self storeManifestFileIn: fd.
+ self compressFilesIn: fd to: aFileName in: aDirectory.
+
+ ^ true
+ !
Item was changed:
----- 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."
+ ^ self exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: false!
- | 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: aChangeSetOrNil; add: thumbnail; 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: [world firstHand 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>>exportSegmentWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') -----
+ exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName
+ directory: aDirectory withoutInteraction: noInteraction
+ "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].
+
+ Utilities emptyScrapsBook.
+ world cleanUpReferences.
+ 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: [
+ noInteraction ifTrue: [^ false].
+ self error: 'Still holding onto Global flaps'].
+ world releaseSqueakPages.
+ Smalltalk at: #ScriptEditorMorph ifPresent: [:s |
+ s writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false])].
+ 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: aChangeSetOrNil; add: thumbnail; 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 changed:
----- Method: MorphicProject>>updateLocaleDependents (in category 'language') -----
updateLocaleDependents
"Set the project's natural language as indicated"
ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
viewerOrScriptor localeChanged].
Flaps disableGlobalFlaps: false.
+ (Preferences eToyFriendly or: [Smalltalk globals at: #SugarNavigatorBar ifPresent: [:c | c showSugarNavigator] ifAbsent: [false]])
- Preferences eToyFriendly
ifTrue: [
Flaps addAndEnableEToyFlaps.
ActiveWorld addGlobalFlaps]
ifFalse: [Flaps enableGlobalFlaps].
(Project current isFlapIDEnabled: 'Navigator' translated)
ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].
ScrapBook default emptyScrapBook.
MenuIcons initializeTranslations.
super updateLocaleDependents.
"self setFlaps.
self setPaletteFor: aLanguageSymbol."
!
Item was changed:
----- 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 := 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 wantsMouseOverHalos: false.
proto beSticky.
^ proto!
Item was changed:
----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
"Answer a basis for names of default instances of the receiver"
+ ^ 'playfield' translatedNoop!
- ^ 'playfield'!
Item was changed:
----- Method: PasteUpMorph>>addCustomMenuItems:hand: (in category 'menu & halo') -----
addCustomMenuItems: menu hand: aHandMorph
"Add morph-specific menu itemns to the menu for the hand"
+ | twm |
super addCustomMenuItems: menu hand: aHandMorph.
- menu addLine.
Preferences noviceMode
ifFalse: [
+ menu addLine.
self addStackMenuItems: menu hand: aHandMorph.
self addPenMenuItems: menu hand: aHandMorph.
self addPlayfieldMenuItems: menu hand: aHandMorph].
+ (self isWorldMorph and: [Preferences noviceMode not])
- self isWorldMorph
ifTrue: [
menu addLine.
+ (owner isKindOf: BOBTransformationMorph)
+ ifTrue: [self addScalingMenuItems: menu hand: aHandMorph].
- 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.
+ menu addLine.
- twm := TheWorldMenu new.
- twm world: self project: Project current hand: aHandMorph.
+ twm := TheWorldMenu new.
+ twm world: self project: Project current hand: aHandMorph.
+
+ menu add: 'old desktop menu... (W)' translated subMenu: twm buildWorldMenu.
- menu add: 'old desktop menu... (W)' translated subMenu: twm buildWorldMenu.
- ].
].
!
Item was changed:
----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') -----
addPenMenuItems: menu hand: aHandMorph
"Add a pen-trails-within submenu to the given menu"
+ menu add: 'pen trails...' translated target: self selector: #putUpPenTrailsSubmenu.
+ menu balloonTextForLastItem: 'its governing pen trails drawn within' translated!
- menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu!
Item was changed:
----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') -----
addPenTrailsMenuItemsTo: aMenu
"Add items relating to pen trails to aMenu"
| oldTarget |
+ oldTarget _ aMenu defaultTarget.
- 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 addLine.
+ aMenu addUpdating: #batchPenTrailsString action: #toggleBatchPenTrails.
+ aMenu balloonTextForLastItem: 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.' translated.
+
aMenu defaultTarget: oldTarget!
Item was changed:
----- Method: PasteUpMorph>>addWorldToggleItemsToHaloMenu: (in category 'menu & halo') -----
addWorldToggleItemsToHaloMenu: aMenu
+ "Add toggle items for the world to the halo menu .... July 2009: no longer in world halo menu"
- "Add toggle items for the world to the halo menu"
+ "aMenu addUpdating: #showTabsString
+ target: CurrentProjectRefactoring
+ action: #currentToggleFlapsSuppressed "!
- #(
- (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 changed:
----- 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.
+ self changed "redraw"
- self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
!
Item was changed:
----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') -----
chooseClickTarget
Cursor crossHair showWhile:
[Sensor waitButton].
Cursor down showWhile:
[Sensor anyButtonPressed].
+ ^ (self morphsAt: Sensor cursorPoint) first topRendererOrSelf!
- ^ (self morphsAt: Sensor cursorPoint) first!
Item was changed:
----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') -----
correspondingFlapTab
+ "If there is a flap tab whose referent is me, return it, else return nil. Will also work for flaps on the edge of embedded subareas such as within scripting-areas, but more slowly."
+
- "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]].
+
+ "Catch guys in embedded worldlets"
+ ActiveWorld allMorphs do:
+ [:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]].
+
^ nil!
Item was changed:
----- 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' translatedNoop]!
- ['world']!
Item was changed:
----- 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@0) anyShapeFill reverse.
+ screenForm _ Form fromDisplay: (topLeft extent: outline extent).
- outline := poly shadowForm.
- topLeft := outline offset.
- exterior := (outline offset: 0@0) anyShapeFill reverse.
- screenForm := Form fromDisplay: (topLeft extent: outline extent).
screenForm eraseShape: exterior.
+ innerForm _ screenForm trimBordersOfColor: Color transparent.
+ ActiveHand showTemporaryCursor: nil.
- innerForm := screenForm trimBordersOfColor: Color transparent.
innerForm isAllWhite ifFalse:
[hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was changed:
----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
flapTab
+ "Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'"
+
| ww |
self isFlap ifFalse:[^nil].
+ ww _ self presenter associatedMorph ifNil: [ActiveWorld].
+ ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]!
- ww := self world ifNil: [World].
- ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]!
Item was changed:
----- 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>'])
+ , 'grid visible when gridding' translated!
- , 'show grid when gridding' translated!
Item was changed:
----- Method: PasteUpMorph>>installFlaps (in category 'world state') -----
installFlaps
"Get flaps installed within the bounds of the receiver"
+ | localFlapTabs |
Project current assureFlapIntegrity.
self addGlobalFlaps.
+ localFlapTabs := self localFlapTabs.
+ localFlapTabs do: [:each | each visible: false].
+
+ Preferences eToyFriendly ifTrue: [
+ ProgressInitiationException display: 'Building Viewers...' translated
+ during: [:bar |
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld.
+ bar value: i / self localFlapTabs size]].
+ ] ifFalse: [
+ localFlapTabs keysAndValuesDo: [:i :each |
+ each adaptToWorld.
+ each visible: true.
+ self displayWorld]].
+
- self localFlapTabs do:
- [:aFlapTab | aFlapTab adaptToWorld].
self assureFlapTabsFitOnScreen.
self bringTopmostsToFront!
Item was changed:
----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') -----
presentCardAndStackMenu
"Put up a menu holding card/stack-related options."
| aMenu |
+ aMenu _ MenuMorph new defaultTarget: self.
- aMenu := MenuMorph new defaultTarget: self.
aMenu addStayUpItem.
+ aMenu addTitle: 'card and stack' translated.
+ aMenu add: 'add new card' translated action: #insertCard.
+ aMenu add: 'delete this card' translated action: #deleteCard.
+ aMenu add: 'go to next card' translated action: #goToNextCardInStack.
+ aMenu add: 'go to previous card' translated action: #goToPreviousCardInStack.
- 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' translated action: #showForegroundObjects.
+ aMenu add: 'show background objects' translated action: #showBackgroundObjects.
+ aMenu add: 'show designations' translated action: #showDesignationsOfObjects.
+ aMenu add: 'explain designations' translated action: #explainDesignations.
- 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 changed:
----- Method: PasteUpMorph>>referencePool (in category 'objects from disk') -----
referencePool
^ self
valueOfProperty: #References
+ ifAbsentPut: [WeakValueDictionary new]
+ !
- ifAbsentPut: [OrderedCollection new]
-
- !
Item was changed:
----- 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 changed:
----- 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]!
- aPlayer startRunning; step; stopRunning].
-
- self allScriptors do:
- [:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
- !
Item was changed:
----- 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 stopSound.
+ aPlayer stopRunning].
- aPlayer stopRunning].
- self allScriptors do:
- [:aScript | aScript pauseIfTicking].
self world updateStatusForAllScriptEditors!
Item was changed:
----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') -----
triggerClosingScripts
"If the receiver has any scripts set to run on closing, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllClosingScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllClosingScripts]!
Item was changed:
----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') -----
triggerOpeningScripts
"If the receiver has any scripts set to run on opening, run them now"
| aPlayer |
+ self allMorphsDo:[ :m|
+ (aPlayer := m player) ifNotNil:
+ [aPlayer runAllOpeningScripts]]!
- (aPlayer := self player) ifNotNil:
- [aPlayer runAllOpeningScripts]!
Item was changed:
----- 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:
+ [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]!
- [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 changed:
----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
setTextColor: aColor
"Set the color of my text to the given color"
+ textMorph textColor: aColor!
- textMorph color: aColor!
Item was changed:
----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Polygon' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ 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.' translatedNoop!
- ^ 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 changed:
----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') -----
+ addCustomMenuItems: aMenu 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."
+
- addCustomMenuItems: aMenu hand: aHandMorph
- | |
super addCustomMenuItems: aMenu hand: aHandMorph.
+ aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles.
+ vertices size > 2 ifTrue:
+ [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed].
+
+ aMenu addUpdating: #smoothPhrase target: self action: #toggleSmoothing.
+ aMenu addLine.
+ aMenu add: 'specify dashed line' translated action: #specifyDashedLine.
+
+ self isOpen ifTrue:
+ [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]].!
- 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 changed:
----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
+
+ ^ Color black
+
+ "Until September 2007, this had long been...
^ Color
r: 0.0
g: 0.419
+ b: 0.935"!
- b: 0.935!
Item was changed:
----- Method: PolygonMorph>>fillStyle (in category 'visual properties') -----
fillStyle
+ "Answer the receiver's fillStyle. For an *open* polygon, we return the borderColor, provided it's a true color rather than something strange like the symbol #raised."
+ | aColor |
self isOpen
+ ifTrue:
+ [(aColor := self borderColor) isColor ifTrue: [^ aColor]]. "easy access to line color from halo -- di's old note"
+
+ ^ super fillStyle!
- ifTrue: [^ self borderColor "easy access to line color from halo"]
- ifFalse: [^ super fillStyle]!
Item was changed:
----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') -----
handlesShowingPhrase
+ "Answer a phrase characterizing whether handles are showing or not."
+
+ ^ (self showingHandles ifTrue: ['<yes>'] ifFalse: ['<no>']), ('show handles' translated)!
- ^ (self showingHandles
- ifTrue: ['hide handles']
- ifFalse: ['show handles']) translated!
Item was changed:
----- Method: PolygonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
+ "Handle a mouse-down event."
+ ^ (evt shiftPressed and: [(self hasProperty: #activateOnShift) not])
- ^ 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 changed:
----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') -----
openOrClosePhrase
+ "Answer a string indicating whether the receiver is open or closed."
+
+ ^ (closed ifTrue: ['<yes>'] ifFalse: ['<no>']), 'closed' translated!
- | 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 changed:
----- Method: PolygonMorph>>stepTime (in category 'testing') -----
stepTime
+ "Answer the desired time between steps in milliseconds."
+ ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [100]
+
+ "NB: in all currently known cases, polygons are not actually wrapped in TransformationMorphs, so the #topRendererOrSelf call above is probably redundant, but is retained for safety."!
- ^ 100!
Item was changed:
----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') -----
+ verticesAt: anInteger put: aPoint
+
+ self vertices at: anInteger put: aPoint asFloatPoint.
- verticesAt: ix put: newPoint
- vertices at: ix put: newPoint.
self computeBounds!
Item was changed:
----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') -----
allCurrentlyTickingScriptInstantiations
+ "Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking."
+
+ ^ Array streamContents:
+ [:aStream |
+ self allExtantPlayers do:
+ [:aPlayer | aPlayer instantiatedUserScriptsDo:
+ [:aScriptInstantiation |
+ aScriptInstantiation status == #ticking ifTrue:
+ [aStream nextPut: aScriptInstantiation]]]]!
- ^#()!
Item was changed:
----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') -----
+ browseAllScriptsTextually
+ "Open a method-list browser on all the scripts in the project"
+
+ | aList aMethodList |
+ self flushPlayerListCache. "Just to be certain we get everything"
+
+ (aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players' translated].
+ aMethodList _ OrderedCollection new.
+ aList do:
+ [:aPair | aPair first addMethodReferencesTo: aMethodList].
+ aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!' translated].
+
+ SystemNavigation new
+ browseMessageList: aMethodList
+ name: 'All scripts in this project'
+ autoSelect: nil
+
+ "
+ ActiveWorld presenter browseAllScriptsTextually
+ "!
- browseAllScriptsTextually!
Item was changed:
----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'ProjectView' translatedNoop!
- ^ 'ProjectView'!
Item was changed:
----- 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' translatedNoop
- label: 'load as project'
selector: #openFromDirectoryAndFileName:
+ description: 'open project from file' translatedNoop
+ buttonLabel: 'load' translatedNoop
- description: 'open project from file'
- buttonLabel: 'load'
)
argumentGetter: [ :fileList | fileList dirAndFileName]!
Item was changed:
----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt
+ "Accept -- in a custom sense here -- a morph dropped on the receiver."
| 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 dropEnabled ifFalse:
+ [^ 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.
- 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 changed:
----- Method: ProjectViewMorph>>dismissViaHalo (in category 'initialization') -----
dismissViaHalo
+ "The user clicked on the dismiss icon on the halo."
+
| choice |
+ project ifNil: [^ self delete]. "no current project"
+ choice := (PopUpMenu labelArray:{
+ 'yes - delete icon and remove the project' translated.
+ 'no - delete icon but keep the project' translated.
+ 'cancel - do not delete anything' translated.
+ }) startUpWithCaption: ('Do you really want to delete the
+ project named {1}
+ and all its contents?' translated format: {project name printString}).
+ choice = 1 ifTrue: [^ self expungeProject].
+ choice = 2 ifTrue: [^ self delete]!
- 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 changed:
----- 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' translated
- ^self inform: 'The project is not present and may not be renamed now'
].
self addProjectNameMorph launchMiniEditor: evt.!
Item was changed:
----- 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' translated]].
- 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 changed:
----- Method: ProjectViewMorph>>fontForName (in category 'drawing') -----
fontForName
+ ^(TextStyle default fontOfSize: 15) emphasized: 1
- | 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 changed:
----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver."
+
super initialize.
+ "currentBorderColor _ Color gray."
+ self addProjectNameMorphFiller.
+ self enableDragNDrop: true.
+ self isOpaque: true.
+ !
- "currentBorderColor := Color gray."
- self addProjectNameMorphFiller.!
Item was changed:
----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
+ "Answer if the receiver would accept a drop of a given morph."
+ "If drop-enabled not set, answer false"
+ (super wantsDroppedMorph: aMorph event: evt) ifFalse: [^ false].
+
+ "If project not present, not morphic, or not initialized, answer false"
+ self isTheRealProjectPresent ifFalse: [^ false].
+ project isMorphic ifFalse: [^ false].
+ project world viewBox ifNil: [^ false].
+
+ ^ true!
- self isTheRealProjectPresent ifFalse: [^false].
- project isMorphic ifFalse: [^false].
- project world viewBox ifNil: [^false]. "uninitialized"
- ^true!
Item was changed:
----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'Rectangle' translatedNoop
+ categories: {'Graphics' translatedNoop. 'Basic' translatedNoop}
+ documentation: 'A rectangular shape, with border and fill style' translatedNoop!
- ^ self partName: 'Rectangle'
- categories: #('Graphics' 'Basic')
- documentation: 'A rectangular shape, with border and fill style'!
Item was changed:
----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') -----
roundRectPrototype
+ "Answer a prototypical RoundRect object for a parts bin."
+
^ self authoringPrototype useRoundedCorners
+ color: (Color r: 1.0 g: 0.3 b: 0.6);
- color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5);
borderWidth: 1;
setNameTo: 'RoundRect'!
Item was changed:
----- 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].
+ (self valueOfProperty: #withMenuButton) == false ifTrue: [^ nil].
+ menu _ MenuMorph new defaultTarget: model.
+ aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
- menu := MenuMorph new defaultTarget: model.
- aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
getMenuSelector numArgs = 1 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu.
- [aMenu := model perform: getMenuSelector with: menu.
aTitle ifNotNil: [aMenu addTitle: aTitle].
^ aMenu].
getMenuSelector numArgs = 2 ifTrue:
+ [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
- [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 changed:
----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Selection' translatedNoop!
- ^ 'Selection'!
Item was changed:
----- 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}.
+ #-.
+ {'distribute vertically' translated. #distributeVertically}.
+ {'distribute horizontally' translated. #distributeHorizontally}.
+ }
- }.
+
- self selectedItems size > 2
- ifTrue:[
- aMenu addList: {
- #-.
- {'distribute vertically' translated. #distributeVertically}.
- {'distribute horizontally' translated. #distributeHorizontally}.
- }.
- ].
!
Item was changed:
----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
+ selectedItems do: [:m | m dismissViaHalo].
-
super dismissViaHalo.
+ !
- selectedItems do: [:m | m dismissViaHalo]!
Item was changed:
----- Method: SelectionMorph>>extent: (in category 'geometry') -----
extent: newExtent
+ "Set the receiver's extent Extend or contract the receiver's selection to encompass morphs within the new extent."
super extent: newExtent.
+ self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])!
- self selectSubmorphsOf: self pasteUpMorph!
Item was changed:
----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: evt
+ "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
selectedItems isEmpty ifTrue:
["Hand just clicked down to draw out a new selection"
^ self extendByHand: evt hand].
+ dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
- 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)] fixTemps].
+ selectedItems _ nil.
+ self removeHalo.
+ self halo ifNotNil: [self halo visible: false].
+ self delete.
- (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]].
evt wasHandled: true!
Item was changed:
----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') -----
selectSubmorphsOf: aMorph
+ "Given the receiver's current bounds, select submorphs of the indicated pasteup morph that fall entirely within those bounds. If nobody is within the bounds, delete the receiver."
| newItems removals |
+ newItems _ aMorph submorphs select:
- newItems := aMorph submorphs select:
[:m | (bounds containsRect: m fullBounds)
and: [m~~self
and: [(m isKindOf: HaloMorph) not]]].
+ otherSelection ifNil: [^ selectedItems _ newItems].
- otherSelection ifNil: [^ selectedItems := newItems].
+ removals _ newItems intersection: itemsAlreadySelected.
- removals := newItems intersection: itemsAlreadySelected.
otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
+ selectedItems _ (newItems copyWithoutAll: removals).
+ selectedItems ifEmpty: [self delete]
- selectedItems := (newItems copyWithoutAll: removals).
!
Item was changed:
----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') -----
slideToTrash: evt
self delete.
+ "selectedItems do: [:m | m slideToTrash: evt]"!
- selectedItems do: [:m | m slideToTrash: evt]!
Item was changed:
----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') -----
hasContentsInExplorer
+ ^self notEmpty!
- ^self isEmpty not!
Item was changed:
----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') -----
defaultNameStemForInstances
^ self = SimpleButtonMorph
+ ifTrue: ['Button' translatedNoop]
- ifTrue: ['Button']
ifFalse: [^ super defaultNameStemForInstances]!
Item was changed:
----- 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 action selector' translated action: #setActionSelector.
aCustomMenu add: 'change arguments' translated action: #setArguments.
aCustomMenu add: 'change when to act' translated action: #setActWhen.
+ aCustomMenu add: 'set target' translated action: #sightTargets:.
+ target ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]].
- self addTargetingMenuItems: aCustomMenu hand: aHandMorph .].
!
Item was changed:
----- 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:
+ [target perform: actionSelector withArguments: arguments].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments]].
actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]!
Item was changed:
----- 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."
+ ^ super 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.
+ Feb 2007: It seems unlikely that Squeak Pages will be used in the OLPC image. Don't use this code. Consider removing all code that supports SqueakPages."
+ "
| bb thatPage um stem ind sqPg |
(actionSelector == #goToPageMorph:fromBookmark:) |
(actionSelector == #goToPageMorph:) ifFalse: [
+ ^ super objectForDataStream: refStrm]. 'normal case'.
- ^ super objectForDataStream: refStrm]. "normal case"
+ target url ifNil: ['Later force target book to get a url.'.
+ bb _ SimpleButtonMorph new. 'write out a dummy'.
- 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.
- (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.
- 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.
- 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'.
- 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
+ "!
- ^ um!
Item was changed:
----- Method: SimpleButtonMorph>>updateVisualState: (in category 'visual properties') -----
updateVisualState: evt
oldColor ifNotNil: [
self color:
((self containsPoint: evt cursorPoint)
+ ifTrue: [oldColor mixed: 0.5 with: Color white]
- ifTrue: [oldColor mixed: 1/2 with: Color white]
ifFalse: [oldColor])]
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ self setProperty: #autoExpand toValue: false.
self
on: #mouseMove
send: #mouseStillDown:onItem:
to: self!
Item was changed:
----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Sketch' translatedNoop!
- ^ 'Sketch'!
Item was changed:
----- Method: SketchMorph>>addToggleItemsToHaloMenu: (in category 'menus') -----
addToggleItemsToHaloMenu: aCustomMenu
+ "Add toggle-items to the halo menu"
+
- "Add toggle-items to the halo menu"
super addToggleItemsToHaloMenu: aCustomMenu.
+ (Smalltalk includesKey: #B3DRenderEngine) ifTrue: [
+ aCustomMenu addUpdating: #useInterpolationString target: self action: #toggleInterpolation.
+ ].
+ !
- Preferences noviceMode
- ifFalse: [""aCustomMenu
- addUpdating: #useInterpolationString
- target: self
- action: #toggleInterpolation]!
Item was changed:
----- Method: SketchMorph>>collapse (in category 'menus') -----
collapse
+ "Replace the receiver with a collapsed rendition of itself."
-
- | priorPosition w collapsedVersion a |
+ | w collapsedVersion a ht tab |
+
+ (w _ self world) ifNil: [^self].
+ collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
- (w := self world) ifNil: [^self].
- collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph.
collapsedVersion setProperty: #uncollapsedMorph toValue: self.
collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
+
+ collapsedVersion setBalloonText: ('A collapsed version of {1}. Click to open it back up.' translated format: {self externalName}).
+
- collapsedVersion setBalloonText: 'A collapsed version of ',self name.
-
self delete.
w addMorphFront: (
+ a _ AlignmentMorph newRow
- a := AlignmentMorph newRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 4;
borderColor: Color white;
+ addMorph: collapsedVersion;
+ yourself).
+ a setNameTo: self externalName.
+ ht := (tab := Smalltalk at: #SugarNavTab ifPresent: [:c | ActiveWorld findA: c])
+ ifNotNil:
+ [tab height]
+ ifNil:
+ [80].
+ a position: 0@ht.
+
- addMorph: collapsedVersion
- ).
collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+ (self valueOfProperty: #collapsedPosition) ifNotNilDo:
+ [:priorPosition |
+ a position: priorPosition]!
- (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil])
- ifNotNil:
- [a position: priorPosition].
- !
Item was changed:
----- 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 x = 0 or: [newExtent y = 0]) ifTrue: [ ^self ].
- newExtent isZero ifTrue: [ ^self ].
self extent = newExtent ifTrue:[^self].
self scalePoint: newExtent asFloatPoint / (originalForm extent max: 1@1).
self layoutChanged.
!
Item was changed:
----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') -----
flipHorizontal
+ | r |
+ r _ self rotationCenter.
+ self left: self left - (1.0 - (2 * r x) * self width).
+ self form: (self form flipBy: #horizontal centerAt: self form center).
+ self rotationCenter: (1 - r x) @ (r y).!
- self form: (self form flipBy: #horizontal centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>flipVertical (in category 'e-toy support') -----
flipVertical
+ | r |
+ r _ self rotationCenter.
+ self top: self top - (1.0 - (2 * r y) * self height).
+ self form: (self form flipBy: #vertical centerAt: self form center).
+ self rotationCenter: r x @ (1 - r y).!
- self form: (self form flipBy: #vertical centerAt: self form center)!
Item was changed:
----- Method: SketchMorph>>initializeWith: (in category 'initialization') -----
initializeWith: aForm
super initialize.
+ originalForm _ aForm.
+ rotationStyle _ #normal. "styles: #normal, #leftRight, #upDown, or #none"
+ scalePoint _ 1.0(a)1.0.
+ framesToDwell _ 1.
+ rotatedForm _ originalForm. "cached rotation of originalForm"
- originalForm := aForm.
- self rotationCenter: 0.5(a)0.5. "relative to the top-left corner of the Form"
- rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none"
- scalePoint := 1.0(a)1.0.
- framesToDwell := 1.
- rotatedForm := originalForm. "cached rotation of originalForm"
self extent: originalForm extent.
!
Item was changed:
----- 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
+ Because my rendering code flips the form (see generateRotatedForm) we 'pre-flip' it here to preserve the same visual appearance.
+ "
- #none -- do not rotate"
+ | wasFlippedX wasFlippedY isFlippedX isFlippedY |
+ wasFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ wasFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ rotationStyle _ aSymbol.
+
+ isFlippedX := rotationStyle == #leftRight
+ and: [ self heading asSmallAngleDegrees < 0.0 ].
+ isFlippedY := rotationStyle == #upDown
+ and: [ self heading asSmallAngleDegrees abs > 90.0 ].
+
+ wasFlippedX == isFlippedX
+ ifFalse: [self form: (self form flipBy: #horizontal centerAt: self form center)].
+ wasFlippedY == isFlippedY
+ ifFalse: [self form: (self form flipBy: #vertical centerAt: self form center)].
+
- rotationStyle := aSymbol.
self layoutChanged.
!
Item was changed:
----- Method: Slider>>sliderThickness (in category 'geometry') -----
sliderThickness
+ "^ 7"
+
+ | w |
+ w _ bounds isWide
+ ifTrue: [super height]
+ ifFalse: [super width].
+
+ ^ (w // 32) max: 16.
+ !
- ^ 7!
Item was changed:
----- 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: [FormDictionary at: #Cat]].
+ ^ FormDictionary at: #Cat!
- [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]].
- ^ nil!
Item was changed:
----- 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.
+ aCustomMenu addUpdating: #usePangoString target: self action: #toggleUsePango.
!
Item was changed:
----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') -----
addOptionalHandlesTo: aHalo box: box
+ "eventually, add more handles for font..."
+
self flag: #deferred.
+ ^ super addOptionalHandlesTo: aHalo box: box
"Eventually...
self addFontHandlesTo: aHalo box: box"!
Item was changed:
----- 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 projectParameterAt: #substitutedFont).
+ (substituteFont notNil and: [self font == substituteFont])
- substituteFont := aProject projectParameters at:
- #substitutedFont ifAbsent: [#none].
- (substituteFont ~~ #none and: [self font == substituteFont])
ifTrue: [ self fitContents ].
^ super fixUponLoad: aProject seg: anImageSegment!
Item was changed:
----- Method: StringMorph>>font: (in category 'printing') -----
font: aFont
"Set the font my text will use. The emphasis remains unchanged."
+ aFont = font ifTrue: [^ self].
+ font _ aFont.
- font := aFont.
^ self font: font emphasis: emphasis!
Item was changed:
----- Method: StringMorphEditor>>initialize (in category 'display') -----
initialize
"Initialize the receiver. Give it a white background"
super initialize.
self backgroundColor: Color white.
+ self textColor: Color red.!
- self color: Color red!
Item was changed:
----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
+ ^ self partName: 'TrueType banner' translatedNoop
+ categories: #()
+ documentation: 'A short text in a beautiful font. Use the resize handle to change size.' translatedNoop!
- ^ self partName: 'TrueType banner'
- categories: #('Demo')
- documentation: 'A short text in a beautiful font. Use the resize handle to change size.'!
Item was changed:
----- 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' translatedNoop. 'A scrolling data field which will have a different value on every card of the background' translatedNoop}
- 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 changed:
----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') -----
borderedPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t fontName: 'BitstreamVeraSans' pointSize: 24.
t autoFit: false; extent: 250@100.
+ t borderWidth: 1; margins: 4@0; backgroundColor: Color white.
- t borderWidth: 1; margins: 4@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 changed:
----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') -----
defaultNameStemForInstances
+ ^ 'Text' translatedNoop!
- ^ 'Text'!
Item was changed:
----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') -----
fancyPrototype
| t |
+ t _ self authoringPrototype.
- t := self authoringPrototype.
t autoFit: false; extent: 150@75.
t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?"
"fancy font, shadow, rounded"
+ t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; fillStyle: Color lightBrown.
- 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 changed:
----- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- 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' translatedNoop. 'A piece of text that will occur on every card of the background' translatedNoop}
- 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' translatedNoop. 'A data field which will have a different value on every card of the background' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you wish' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish')
forFlapNamed: 'Stack Tools'.
+ cl registerQuad: {#TextMorph . #fancyPrototype. 'Fancy Text' translatedNoop. 'A text field with a rounded shadowed border, with a fancy font.' translatedNoop}
- 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' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop}
- cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.')
forFlapNamed: 'Supplies'.]!
Item was changed:
----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
"Overridden from BorderedMorph to test backgroundColor instead of (text) color."
+ (self backgroundColor isNil or: [self backgroundColor asColor isTranslucent])
- (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 changed:
----- Method: TextMorph>>backgroundColor (in category 'accessing') -----
backgroundColor
+ ^ self fillStyle.
+ !
- ^ backgroundColor!
Item was changed:
----- Method: TextMorph>>backgroundColor: (in category 'accessing') -----
backgroundColor: newColor
+ self fillStyle: newColor.
+ !
- backgroundColor := newColor.
- self changed!
Item was changed:
----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
beAllFont: aFont
+ textStyle _ TextStyle fontArray: (Array with: aFont).
+ text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)].
- textStyle := TextStyle fontArray: (Array with: aFont).
self releaseCachedState; changed!
Item was changed:
----- Method: TextMorph>>defaultLineHeight (in category 'geometry') -----
defaultLineHeight
+ ^ ( textStyle fontAt: textStyle defaultFontIndex) pointSize!
- ^ textStyle lineGrid!
Item was changed:
----- 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 wid |
- | newExtent para cBounds lastOfLines heightOfLast |
self isAutoFit
ifTrue:
+ [wid _ (text notNil and: [text size > 2]) ifTrue: [5] ifFalse: [40].
+ newExtent := (self paragraph extent max: wid @ ( self defaultLineHeight)) + (0 @ 2).
- [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 changed:
----- Method: TextMorph>>insertCharacters: (in category 'scripting access') -----
+ insertCharacters: aString
- insertCharacters: aSource
"Insert the characters from the given source at my current cursor position"
+ | aLoc aText attributes |
- | aLoc |
aLoc := self cursor max: 1.
+ aText := aLoc > text size
+ ifTrue: [aString asText]
+ ifFalse: [
+ attributes := (text attributesAt: aLoc)
+ select: [:attr | attr mayBeExtended].
+ Text string: aString attributes: attributes].
+ paragraph replaceFrom: aLoc to: (aLoc - 1) with: aText displaying: true.
- paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true.
self updateFromParagraph !
Item was changed:
----- 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].
- [paragraph := nil].
container ifNotNil:
+ [container isMorph ifTrue: [container releaseCachedState]]!
- [container releaseCachedState]!
Item was changed:
----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') -----
setAllButFirstCharacter: source
"Set all but the first char of the receiver to the source"
+ | chars |
+ (chars _ self getCharacters) isEmpty
- | aChar chars |
- aChar := source asCharacter.
- (chars := self getCharacters) isEmpty
ifTrue: [self newContents: 'ยท' , source asString]
+ ifFalse: [self newContents: (String
- ifFalse: [chars first = aChar
- ifFalse: [""
- self
- newContents: (String
streamContents: [:aStream |
aStream nextPut: chars first.
+ aStream nextPutAll: source])]!
- aStream nextPutAll: source])]] !
Item was changed:
----- Method: TextMorph>>textColor: (in category 'accessing') -----
textColor: aColor
+ self editor selectFrom: 1 to: 0.
+ self selectionColor: aColor.
- color = aColor ifTrue: [^ self].
- color := aColor.
- self changed.
!
Item was changed:
----- Method: TheWorldMenu>>remoteMenu (in category 'construction') -----
remoteMenu
"Build the Telemorphic menu for the world."
+ ^self fillIn: (self menu: 'Telemorphic' translatedNoop) from: {
+ { 'local host address' translatedNoop. { #myWorld . #reportLocalAddress } }.
+ { 'connect remote user' translatedNoop. { #myWorld . #connectRemoteUser } }.
+ { 'disconnect remote user' translatedNoop. { #myWorld . #disconnectRemoteUser } }.
+ { 'disconnect all remote users' translatedNoop. { #myWorld . #disconnectAllRemoteUsers } }.
- ^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 changed:
----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') -----
windowsMenu
"Build the windows menu for the world."
+ ^ self fillIn: (self menu: 'windows' translatedNoop) from: {
+ { 'find window' translatedNoop. { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' translatedNoop}.
- ^ 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...' translatedNoop. { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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...' translatedNoop. { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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)' translatedNoop. { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' translatedNoop}.
- { '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.' translatedNoop}.
- tile: new windows positioned so that they do not overlap others, if possible.'}.
nil.
+ { 'collapse all windows' translatedNoop. { #myWorld . #collapseAllWindows }. 'Reduce all open windows to collapsed forms that only show titles.' translatedNoop}.
+ { 'collapse all objects' translatedNoop. { #myWorld . #collapseAllWindowsAndNonWindows }. 'Reduce all open windows and all other objects on the desktop to labeled tabs' translatedNoop}.
+ { 'expand all' translatedNoop. { #myWorld . #expandAllCollapsedObjects }. 'Expand all collapsed windows and other collapsed objects back to their expanded forms.' translatedNoop}.
+
+ { 'close top window (w)' translatedNoop. { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.' translatedNoop}.
+ { 'send top window to back (\)' translatedNoop. { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.' translatedNoop}.
+ { 'move windows onscreen' translatedNoop. { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen' translatedNoop}.
- { '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' translatedNoop. { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.' translatedNoop}.
+ { 'delete non-windows' translatedNoop. { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.' translatedNoop}.
+ { 'delete both of the above' translatedNoop. { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' translatedNoop}.
- { '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 changed:
----- 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."
+ | args |
(target notNil and: [actionSelector notNil])
ifTrue:
+ [args := actionSelector numArgs > arguments size
+ ifTrue:
+ [arguments copyWith: ActiveEvent]
+ ifFalse:
+ [arguments].
+ Cursor normal
+ showWhile: [target perform: actionSelector withArguments: args].
- [Cursor normal
- showWhile: [target perform: actionSelector withArguments: arguments].
target isMorph ifTrue: [target changed]]!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| now dt |
- self state: #pressed.
actWhen == #buttonDown
+ ifTrue: [self doButtonAction].
+ actWhen == #buttonUp
+ ifTrue: [self state: #pressed].
+ actWhen == #whilePressed
+ ifTrue:
+ [self state: #pressed.
+ now _ Time millisecondClockValue.
- 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"
+ "NOTE: this delay is temporary disabled because it makes event reaction delay,
+ e.g. the action is not stopped even if you release the button... - Takashi"
+ [dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
+ self mouseStillDown: evt].
+ super mouseDown: evt!
- dt := Time millisecondClockValue - now max: 0. "Time it took to do"
- dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
- self mouseStillDown: evt.!
Item was changed:
----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') -----
+ mouseMove: evt
+ (#(#buttonUp #whilePressed ) includes: actWhen)
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #pressed]
+ ifFalse: [self state: #off]].
+ super mouseMove: evt!
- 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 changed:
----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') -----
+ mouseUp: evt
- mouseUp: evt
"Allow on:send:to: to set the response to events other than actWhen"
+ actWhen == #buttonDown
+ ifTrue: [super mouseUp: evt].
+ actWhen == #buttonUp
+ ifTrue: [(self containsPoint: evt cursorPoint)
+ ifTrue: [self state: #on.
+ self doButtonAction: evt.
+ super mouseUp: evt]
+ ifFalse: [self state: #off.
+ target
+ ifNotNil: ["Allow owner to keep it selected for radio
+ buttons"
+ target mouseUpBalk: evt]]].
+ actWhen == #whilePressed
+ ifTrue: [self state: #off.
+ super mouseUp: evt]!
- 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 changed:
----- 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: [1]
- ifTrue: [ 2]
ifFalse: [1]!
Item was changed:
----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') -----
fitContents
+ | newExtent |
+ newExtent := self measureContents.
+ newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.
- | 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 changed:
----- Method: UpdatingStringMorph>>initialize (in category 'initialization') -----
initialize
+ "Initialize the receiver to have default values in its instance variables."
- "Initialie the receiver to have default values in its instance
- variables "
super initialize.
""
+ format _ #default.
- format := #default.
"formats: #string, #default"
+ target _ getSelector _ putSelector _ nil.
+ floatPrecision _ 1.
+ growable _ true.
+ stepTime _ nil.
+ autoAcceptOnFocusLoss _ true.
+ minimumWidth _ 8.
+ maximumWidth _ 366!
- target := getSelector := putSelector := nil.
- floatPrecision := 1.
- growable := true.
- stepTime := 50.
- autoAcceptOnFocusLoss := true.
- minimumWidth := 8.
- maximumWidth := 300!
Item was changed:
----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') -----
readFromTarget
"Update my readout from my target"
+ | v ret places |
- | v ret |
(target isNil or: [getSelector isNil]) ifTrue: [^contents].
+ ret _ self checkTarget.
- ret := self checkTarget.
ret ifFalse: [^ '0'].
+ ((target isMorph) or:[target isPlayerLike]) ifTrue:[
+ places _ target decimalPlacesForGetter: getSelector.
+ (places ~= nil and: [ places ~= (self valueOfProperty: #decimalPlaces ifAbsent: [0])]) ifTrue: [ self decimalPlaces: places ]].
v := target perform: getSelector. "scriptPerformer"
(v isKindOf: Text) ifTrue: [v := v asString].
^self acceptValueFromTarget: v!
Item was changed:
----- 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 := MenuMorph new.
aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}).
+ 0 to: 10 do:
- 0 to: 5 do:
[:places |
aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places].
aMenu popUpInWorld!
Item was changed:
----- Method: UpdatingStringMorph>>stepTime (in category 'testing') -----
stepTime
+ ^ stepTime ifNil: [200]
- ^ stepTime ifNil: [50]
!
Item was changed:
----- 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.
+ self setProperty: #decimalPlaces toValue: ((self valueOfProperty: #decimalPlaces ifAbsent: [0]) veryDeepCopyWith: 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.
!
1
0