From ab7e033dfc2963528cd8ff74f042bff669af4464 Mon Sep 17 00:00:00 2001 From: Juan Vuletich Date: Sat, 24 Oct 2020 17:22:08 -0300 Subject: [PATCH] Morph, PasteUpMorph, World refactor --- .../Morphic-Deprecated.pck.st | 72 +- ...uanVuletich-2020Oct23-16h05m-jmv.001.cs.st | 112 ++ ...uanVuletich-2020Oct21-14h49m-jmv.001.cs.st | 95 ++ ...uanVuletich-2020Oct21-16h20m-jmv.001.cs.st | 220 +++ ...uanVuletich-2020Oct21-17h15m-jmv.001.cs.st | 1484 +++++++++++++++++ ...uanVuletich-2020Oct21-17h35m-jmv.001.cs.st | 264 +++ ...uanVuletich-2020Oct22-12h20m-jmv.003.cs.st | 455 +++++ ...uanVuletich-2020Oct23-19h51m-jmv.001.cs.st | 19 + ...uanVuletich-2020Oct23-22h41m-jmv.002.cs.st | 630 +++++++ ...uanVuletich-2020Oct23-23h01m-jmv.001.cs.st | 62 + Packages/BaseImageTests.pck.st | 41 +- Packages/Features/VectorGraphics.pck.st | 226 +-- Packages/Features/Wallpaper.pck.st | 14 +- 13 files changed, 3461 insertions(+), 233 deletions(-) create mode 100644 CoreUpdates/4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st create mode 100644 CoreUpdates/4418-MorphTweaks-JuanVuletich-2020Oct21-14h49m-jmv.001.cs.st create mode 100644 CoreUpdates/4419-RenamePasteUpMorphAsOldPasteUpMorph-JuanVuletich-2020Oct21-16h20m-jmv.001.cs.st create mode 100644 CoreUpdates/4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st create mode 100644 CoreUpdates/4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st create mode 100644 CoreUpdates/4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st create mode 100644 CoreUpdates/4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st create mode 100644 CoreUpdates/4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st create mode 100644 CoreUpdates/4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st diff --git a/CompatibilityPackages/Morphic-Deprecated.pck.st b/CompatibilityPackages/Morphic-Deprecated.pck.st index 1e96b174..2a610e3b 100644 --- a/CompatibilityPackages/Morphic-Deprecated.pck.st +++ b/CompatibilityPackages/Morphic-Deprecated.pck.st @@ -1,11 +1,11 @@ -'From Cuis 5.0 [latest update: #4413] on 15 October 2020 at 12:26:40 pm'! +'From Cuis 5.0 [latest update: #4425] on 24 October 2020 at 5:08:56 pm'! 'Description '! -!provides: 'Morphic-Deprecated' 1 1! +!provides: 'Morphic-Deprecated' 1 2! SystemOrganization addCategory: 'Morphic-Deprecated'! !classDefinition: #RectangleLikeMorph category: 'Morphic-Deprecated'! -Morph subclass: #RectangleLikeMorph +MovableMorph subclass: #RectangleLikeMorph instanceVariableNames: 'extent color' classVariableNames: '' poolDictionaries: '' @@ -24,16 +24,6 @@ RectangleLikeMorph subclass: #BorderedRectMorph BorderedRectMorph class instanceVariableNames: ''! -!classDefinition: #EllipseMorph category: 'Morphic-Deprecated'! -BorderedRectMorph subclass: #EllipseMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Deprecated'! -!classDefinition: 'EllipseMorph class' category: 'Morphic-Deprecated'! -EllipseMorph class - instanceVariableNames: ''! - !classDefinition: #StringMorph category: 'Morphic-Deprecated'! RectangleLikeMorph subclass: #StringMorph instanceVariableNames: 'font emphasis contents' @@ -67,11 +57,6 @@ BorderedRectMorph subclasses can use a variety of border styles: simple, inset, BorderedRectMorph new borderColor: Color red; borderWidth: 10; openInWorld. BorderedRectMorph new borderColor: Color white; openInWorld! -!EllipseMorph commentStamp: '' prior: 0! -A round BorderedMorph. Supports borderWidth and borderColor. - -EllipseMorph new borderWidth:10; borderColor: Color green; openInWorld.! - !StringMorph commentStamp: '' prior: 0! StringMorph is a "lightweight" Morph to display a String. It supports only a single font, color, and emphasis combination. For multiple text styles, use TextModelMorph. @@ -331,46 +316,12 @@ initialize is: aSymbol ^ aSymbol == #BorderedRectMorph or: [ super is: aSymbol ]! ! -!EllipseMorph methodsFor: 'drawing' stamp: 'jmv 4/9/2015 09:43'! -drawOn: aCanvas - - | rx ry | - self revisar. "The morph should be specified better!!" - rx _ extent x //2. - ry _ extent y // 2. - aCanvas ellipseCenterX: rx y: ry rx: rx ry: ry borderWidth: borderWidth borderColor: borderColor fillColor: color! ! - -!EllipseMorph methodsFor: 'geometry testing' stamp: 'jmv 10/7/2009 23:21'! -isOrthoRectangularMorph - ^false! ! - -!EllipseMorph methodsFor: 'geometry testing' stamp: 'pb 3/17/2020 13:36:07'! -morphContainsPoint: aLocalPoint - - | radius other delta xOverY | - (self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [^ false]. "quick elimination" - extent > `1@1` - ifFalse: [^ true]. "Degenerate case -- code below fails by a bit" - - radius _ extent y asFloat / 2. - other _ extent x asFloat / 2. - delta _ aLocalPoint - (other@radius). - xOverY _ extent x asFloat / extent y asFloat. - ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! - -!EllipseMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! -defaultBorderWidth - "answer the default border width for the receiver" - ^ 1! ! - -!EllipseMorph methodsFor: 'visual properties' stamp: 'jmv 3/10/2018 22:24:29'! -defaultColor - "Return the default fill style for the receiver" - ^ `Color yellow`! ! +!StringMorph methodsFor: 'printing' stamp: 'efc 2/22/2003 21:35'! +font: aFont + "Set the font my text will use. The emphasis remains unchanged." -!EllipseMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:50:14'! -categoryInNewMorphMenu - ^ 'Basic'! ! + font _ aFont. + ^ self font: font emphasis: emphasis! ! !StringMorph methodsFor: 'accessing'! contents @@ -494,13 +445,6 @@ changeFont newFont _ AbstractFont fromUser: self fontToUse. newFont ifNotNil:[self font: newFont].! ! -!StringMorph methodsFor: 'printing' stamp: 'efc 2/22/2003 21:35'! -font: aFont - "Set the font my text will use. The emphasis remains unchanged." - - font _ aFont. - ^ self font: font emphasis: emphasis! ! - !StringMorph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:56:36'! fitContents "Measures contents later at #minimumExtent" diff --git a/CoreUpdates/4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st b/CoreUpdates/4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st new file mode 100644 index 00000000..9400d9d3 --- /dev/null +++ b/CoreUpdates/4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st @@ -0,0 +1,112 @@ +'From Cuis 5.0 [latest update: #4416] on 23 October 2020 at 4:14:51 pm'! +!classDefinition: #StringRequestMorph category: 'Morphic-Composite Widgets'! +LayoutMorph subclass: #StringRequestMorph + instanceVariableNames: 'response acceptBlock cancelBlock validationBlock ' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Composite Widgets'! + +!LayoutMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 15:37:44'! +layoutBounds + "Return the bounds for laying out children of the receiver" + + ^ self morphLocalBounds insetBy: borderWidth! ! + + +!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 16:06:31'! +addTextPane + | result | + result _ (TextModelMorph + textProvider: self + textGetter: #response + textSetter: #response: + selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. + self + valueOfProperty: #emptyTextDisplayMessage + ifPresentDo: [ :msg | + result emptyTextDisplayMessage: msg ]. + result + hasUnacceptedEdits: true; + acceptOnCR: true; + escAction: [ self cancel ]. + self addMorph: result layoutSpec: LayoutSpec useAll.! ! + +!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 16:14:23'! +addTitle: aString + | titleMorph s pp w | + titleMorph _ WidgetMorph new noBorder. + titleMorph color: Theme current menuTitleBar. + pp _ `8@2`. + aString asString linesDo: [ :line | + s _ LabelMorph new + contents: line; + font: Preferences standardMenuFont bold. + titleMorph addMorphBack: s position: pp. + pp _ pp + (0@(s morphHeight+2)) ]. + w _ titleMorph submorphs inject: 0 into: [ :prev :each | + prev max: each morphWidth ]. + titleMorph morphExtent: (w + 24) @ (pp y). + self addMorphKeepMorphHeight: titleMorph. + ^titleMorph morphWidth! ! + +!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 15:45:59'! +defaultBorderWidth + "answer the default border width for the receiver" + ^ 5! ! + +!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 16:14:08'! +setQuery: queryString initialAnswer: initialAnswer + | lineCount newExtent w | + response _ initialAnswer. + w _ self addTitle: queryString. + self addTextPane. + "If the initial response is big or has multiple lines we make the text pane bigger and with scrollbars:" + lineCount _ response lineCount. + newExtent _ lineCount > 1 + ifTrue: [ 40 @ (lineCount*2) * FontFamily defaultLineSpacing ] + ifFalse: [ (response size max: 12) @ 3.2 * FontFamily defaultLineSpacing ]. + self morphExtent: (newExtent max: w@0)! ! + + +!StringRequestMorph class methodsFor: 'instance creation' stamp: 'jmv 10/23/2020 15:32:25'! +request: queryString centeredAt: aPoint initialAnswer: defaultAnswer validationBlock: validationBlock acceptBlock: acceptBlock cancelBlock: cancelBlock + | answer | + answer _ self newColumn + setQuery: queryString + initialAnswer: defaultAnswer; + validationBlock: validationBlock; + acceptBlock: acceptBlock; + cancelBlock: cancelBlock. + self runningWorld addMorph: answer centeredNear: aPoint - self deltaToTextPane. + ^ answer! ! + +!StringRequestMorph class methodsFor: 'instance creation' stamp: 'jmv 10/23/2020 15:32:30'! +request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock + + | morph world | + + morph _ self newColumn + setQuery: queryString + initialAnswer: defaultAnswer. + (world _ self runningWorld) addMorph: morph centeredNear: world activeHand morphPosition - self deltaToTextPane. + + ^ morph getUserResponseOrCancel: cancelBlock! ! + +!StringRequestMorph class methodsFor: 'private' stamp: 'jmv 10/23/2020 15:54:06'! +deltaToTextPane + "Answer a distance to translate an instance of the receiver by when it is opened in the world in order to have the hand be over the text pane (so the text pane has focus). + Distance is relative to font size" + | e | + e _ Preferences windowTitleFont lineSpacing. + ^ (0)@(0.5 * e)! ! + +!methodRemoval: StringRequestMorph #intoWorld: stamp: 'jmv 10/23/2020 16:05:21'! +StringRequestMorph removeSelector: #intoWorld:! +!methodRemoval: StringRequestMorph #adjustSubmorphsLayout stamp: 'jmv 10/23/2020 16:05:21'! +StringRequestMorph removeSelector: #adjustSubmorphsLayout! +!classDefinition: #StringRequestMorph category: 'Morphic-Composite Widgets'! +LayoutMorph subclass: #StringRequestMorph + instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Composite Widgets'! diff --git a/CoreUpdates/4418-MorphTweaks-JuanVuletich-2020Oct21-14h49m-jmv.001.cs.st b/CoreUpdates/4418-MorphTweaks-JuanVuletich-2020Oct21-14h49m-jmv.001.cs.st new file mode 100644 index 00000000..e42d762d --- /dev/null +++ b/CoreUpdates/4418-MorphTweaks-JuanVuletich-2020Oct21-14h49m-jmv.001.cs.st @@ -0,0 +1,95 @@ +'From Cuis 5.0 [latest update: #4414] on 21 October 2020 at 3:03:43 pm'! + +!Morph commentStamp: 'jmv 10/21/2020 14:49:13' prior: 0! +A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. + +Morphs exist in a tree, rooted at a World (a WorldMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets +drawn. To hide a Morph and its submorphs, send the #visible: message. + +Every morph has a local coordinate system to interpret positions. +Local coordinates are used in the #drawOn: method (the Canvas understands positions in the local coordinate system), for the positions of submorphs (for example #morphPosition and #morphPosition:) and for positions carried by mouse events. + +Events are delivered to morphs in Z-order, i.e. if a morph occludes another the event is only delivered to the foremost (just like physical objects). Events received by a morph carry positions in the local coordinate system. + +Morphs can be translated by an offset, rotated around their center, orbited (rotated around the owner center), and zoomed (i.e. scaled). + +Every morph has an associated transformation that defines the inner space where the morph is drawn and where the submorphs live. These transformations don't change anything from the internal point of view of the morph. + +Structure: +instance var Type Description +owner Morph My parent Morph, or nil for the top-level Morph, which is a + or nil world, typically a PasteUpMorph. +submorphs Array My child Morphs. +location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner + See comment at GeometryTransformation! + + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:01:06'! +orbitBy: radians + "Change the scale of this morph. Arguments are an angle and a scale." + location _ (AffineTransformation withRadians: radians) composedWith: location. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. + self redrawNeeded.! ! + + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 14:56:59'! +rotation: radians + "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." + + self rotation: radians scale: location scale.! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 14:56:28'! +rotation: radians scale: scale + "Change the rotation and scale of this morph. Arguments are an angle and a scale." + location _ location withRotation: radians scale: scale. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. + self redrawNeeded.! ! + + +!Morph reorganize! +('accessing' adoptWidgetsColor: beSticky color location lock morphId resistsRemoval taskbar toggleStickiness unlock unlockContents) +('accessing - flags' isLayoutNeeded isRedrawNeeded isSubmorphRedrawNeeded layoutNeeded: needsRedraw: submorphNeedsRedraw: visible) +('accessing - properties' hasProperty: isLocked isSticky lock: name name: removeProperty: setProperty:toValue: sticky: valueOfProperty: valueOfProperty:ifAbsent: valueOfProperty:ifPresentDo:) +('as yet unclassified' canDiscardEdits disregardUnacceptedEdits whenUIinSafeState:) +('caching' clearId fullReleaseCachedState releaseCachedState) +('change reporting' addedMorph: invalidateDisplayRect:fromSubmorph:for: invalidateLocalRect:) +('classification' isWorldMorph) +('copying' copy copyForClipboard duplicate) +('debug and other' addDebuggingItemsTo:hand: buildDebugMenu: inspectOwnerChain ownerChain resumeAfterDrawError resumeAfterStepError) +('drawing' addPossiblyUncoveredAreasIn:to: drawOn: drawingFails drawingFailsNot hide icon imageForm: imageForm:depth: isKnownFailing refreshWorld show visible:) +('dropping/grabbing' aboutToBeGrabbedBy: aboutToGrab: acceptDroppingMorph:event: dropFiles: justDroppedInto:event: justGrabbedFrom: rejectDropMorphEvent: wantsDroppedMorph:event: wantsToBeDroppedInto:) +('e-toy support' embeddedInMorphicWindowLabeled: unlockOneSubpart wantsRecolorHandle) +('events' click:localPosition: doubleClick:localPosition: dragEvent:localPosition: keyDown: keyStroke: keyUp: mouseButton1Down:localPosition: mouseButton1Up:localPosition: mouseButton2Down:localPosition: mouseButton2Up:localPosition: mouseButton3Down:localPosition: mouseButton3Up:localPosition: mouseEnter: mouseHover:localPosition: mouseLeave: mouseMove:localPosition: mouseScroll:localPosition: mouseStillDown windowEvent:) +('event handling testing' allowsFilesDrop allowsMorphDrop allowsSubmorphDrag handlesKeyboard handlesMouseDown: handlesMouseHover handlesMouseOver: handlesMouseScroll: handlesMouseStillDown:) +('event handling' mouseButton2Activity mouseStillDownStepRate mouseStillDownThreshold) +('events-alarms' addAlarm:after: addAlarm:with:after: addAlarm:withArguments:after: alarmScheduler removeAlarm:) +('events-processing' dispatchEvent:localPosition: focusKeyboardFor: handleFocusEvent: processDropFiles:localPosition: processDropMorph:localPosition: processKeyDown:localPosition: processKeyUp:localPosition: processKeystroke:localPosition: processMouseDown:localPosition: processMouseEnter:localPosition: processMouseLeave:localPosition: processMouseMove:localPosition: processMouseOver:localPosition: processMouseScroll:localPosition: processMouseStillDown processMouseUp:localPosition: processUnknownEvent:localPosition: processWindowEvent:localPosition: rejectsEvent: rejectsEventFully:) +('fileIn/out' prepareToBeSaved storeDataOn:) +('focus handling' hasKeyboardFocus hasMouseFocus keyboardFocusChange:) +('geometry' allocHeightForFactor: allocWidthForFactor: displayBounds displayBounds: displayBoundsForHalo displayBoundsOrBogus displayFullBounds extentBorder externalize: externalizeDisplayBounds: externalizeDistance: externalizeDistanceToWorld: externalizeToWorld: fontPreferenceChanged internalize: internalizeDistance: internalizeDistanceFromWorld: internalizeFromWorld: minimumExtent minimumLayoutExtent morphAlign:with: morphExtent morphExtent: morphExtentInWorld morphExtentInWorld: morphHeight morphLocalBounds morphPosition morphPosition: morphPositionInWorld morphPositionInWorld: morphTopLeft morphWidth orbitBy: rotateBy: rotation: rotation:scale: rotationDegrees: scaleBy:) +('geometry eToy' referencePosition referencePosition:) +('geometry testing' clipsLastSubmorph fullContainsGlobalPoint: fullContainsPoint: isOrthoRectangularMorph morphContainsPoint: requiresVectorCanvas submorphsMightProtrude) +('halos and balloon help' addHalo addHalo: addHandlesTo:box: addOptionalHandlesTo:box: balloonHelpDelayTime balloonText comeToFrontAndAddHalo deleteBalloon editBalloonHelpContent: editBalloonHelpText halo mouseDownOnHelpHandle: noHelpString okayToBrownDragEasily okayToResizeEasily okayToRotateEasily removeHalo setBalloonText: showBalloon: showBalloon:hand: transferHalo:from: wantsBalloon wantsHalo wantsHaloHandleWithSelector:inHalo:) +('initialization' inATwoWayScrollPane initialize intoWorld: openInHand openInWorld openInWorld:) +('iteration of all morphs' nextMorph nextMorphPart2 nextMorphThat: previousMorph previousMorphThat:) +('layout' layoutSubmorphs layoutSubmorphsIfNeeded minItemWidth minimumLayoutHeight minimumLayoutWidth minimumShrinkExtent minimumShrinkHeight minimumShrinkWidth someSubmorphPositionOrExtentChanged) +('layout-properties' layoutSpec layoutSpec: layoutSpecOrNil) +('macpal' flash flashWith:) +('menus' addAddHandMenuItemsForHalo:hand: addColorMenuItems:hand: addCopyItemsTo: addCustomHaloMenuItems:hand: addCustomMenuItems:hand: addExportMenuItems:hand: addHaloActionsTo: addStandardHaloMenuItemsTo:hand: addTitleForHaloMenu: addToggleItemsToHaloMenu: changeColor expand exportAsBMP exportAsJPEG lockUnlockMorph lockedString maybeAddCollapseItemTo: stickinessString) +('meta-actions' addEmbeddingMenuItemsTo:hand: buildHandleMenu: copyToClipboard: dismissMorph duplicateMorph: maybeDuplicateMorph potentialEmbeddingTargets) +('naming' label) +('object serialization' objectForDataStream:) +('player' okayToDuplicate) +('printing' printOn:) +('rotate scale and flex' rotationDegrees) +('stepping' shouldGetStepsFrom: startStepping startStepping: startStepping:in:stepTime: startStepping:stepTime: startSteppingStepTime: step stepAt: stopStepping stopStepping: wantsSteps) +('structure' allOwnersDo: allOwnersReverseDo: firstOwnerSuchThat: hasOwner: isInWorld owner owningWindow root veryLastLeaf withAllOwnersDo: withAllOwnersReverseDo: world) +('submorphs-accessing' allMorphsDo: clippedSubmorph findDeepSubmorphThat:ifAbsent: findSubmorphBinary: firstSubmorph hasSubmorphs lastSubmorph noteNewOwner: submorphBehind: submorphCount submorphInFrontOf: submorphs submorphsBehind:do: submorphsDo: submorphsDrawingOutsideReverseDo: submorphsInFrontOf:do: submorphsReverseDo: submorphsSatisfying: unclippedSubmorphsReverseDo:) +('submorphs-add/remove' addAllMorphs: addAllMorphs:after: addMorph: addMorph:behind: addMorph:inFrontOf: addMorph:position: addMorphBack: addMorphBack:position: addMorphFront: addMorphFront:position: addMorphFrontFromWorldPosition: atFront canAdd: comeToFront delete dismissViaHalo goBehind privateDelete removeAllMorphs removeAllMorphsIn: removeMorph: removedMorph: replaceSubmorph:by:) +('testing' hasModel is: isCollapsed isOwnedByHand isOwnedByWorld isProportionalHeight isProportionalWidth isReallyVisible stepTime) +('updating' invalidateBounds redrawNeeded) +('user interface' activateWindow activateWindowAndSendTopToBack: collapse showAndComeToFront toggleCollapseOrShow) +('private' privateAddAllMorphs:atIndex: privateAddMorph:atIndex: privateAddMorph:atIndex:position: privateAnyOwnerHandlesMouseScroll: privateFlagAt: privateFlagAt:put: privateMoveBackMorph: privateMoveFrontMorph: privateOwner: privatePosition: privateRemove: privateSubmorphs) +('previewing' beginPreview endPreview endPreviewAndToggleCollapseOrShow morphBehindBeforePreview morphBehindBeforePreview: previewing previewing: visibleBeforePreview visibleBeforePreview:) +! + diff --git a/CoreUpdates/4419-RenamePasteUpMorphAsOldPasteUpMorph-JuanVuletich-2020Oct21-16h20m-jmv.001.cs.st b/CoreUpdates/4419-RenamePasteUpMorphAsOldPasteUpMorph-JuanVuletich-2020Oct21-16h20m-jmv.001.cs.st new file mode 100644 index 00000000..d77bdcc9 --- /dev/null +++ b/CoreUpdates/4419-RenamePasteUpMorphAsOldPasteUpMorph-JuanVuletich-2020Oct21-16h20m-jmv.001.cs.st @@ -0,0 +1,220 @@ +'From Cuis 5.0 [latest update: #4414] on 21 October 2020 at 4:20:37 pm'! +Smalltalk renameClassNamed: #PasteUpMorph as: #OldPasteUpMorph! + +!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/21/2020 16:20:05'! +reduceCuis + " + Smalltalk reduceCuis + " + | keep n unused newDicts oldDicts | + + self nominallyUnsent: #reduceCuis. + + "Remove icons" + Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. + OldPasteUpMorph allInstancesDo: [ :w | + w backgroundImageData: nil. + w submorphsDo: [ :a | a delete ]]. + Preferences useNoMenuIcons. + Theme current initialize. + Theme content: nil. + Color shutDown. + BitBltCanvas releaseClassCachedState. + + Transcript clear. + Clipboard default initialize. + + + "Remove some methods, even if they have senders." + Utilities removeSelector: #vmStatisticsReportString. + SystemDictionary removeSelector: #recreateSpecialObjectsArray. + + StrikeFont saveSpace. + Smalltalk garbageCollect. + + Smalltalk removeEmptyMessageCategories. + Smalltalk organization removeEmptyCategories. + + keep := OrderedCollection new. + keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). + AppLauncher appGlobalName ifNotNil: [ :any | + keep add: any ]. + unused := Smalltalk unusedClasses copyWithoutAll: keep. + [ + #hereWeGo print. + unused do: [:c | + c print. + (Smalltalk at: c) removeFromSystem]. + n := Smalltalk removeAllUnSentMessages. + unused := Smalltalk unusedClasses copyWithoutAll: keep. + n > 0 or: [ + unused notEmpty ]] whileTrue. + ChangeSet zapAllChangeSets. + Smalltalk garbageCollect. + + Smalltalk removeEmptyMessageCategories. + Smalltalk organization removeEmptyCategories. + Symbol rehash. + + "Shrink method dictionaries." + Smalltalk garbageCollect. + oldDicts _ MethodDictionary allInstances. + newDicts _ Array new: oldDicts size. + oldDicts withIndexDo: [:d :index | + newDicts at: index put: d rehashWithoutBecome ]. + oldDicts elementsExchangeIdentityWith: newDicts. + oldDicts _ newDicts _ nil. + + SmalltalkCompleter initialize . + + "Sanity checks" +" Undeclared + Smalltalk cleanOutUndeclared + Smalltalk browseUndeclaredReferences + Smalltalk obsoleteClasses + Smalltalk obsoleteBehaviors + Smalltalk browseObsoleteMethodReferences + SmalltalkImage current fixObsoleteReferences + Smalltalk browseAllUnimplementedCalls"! ! + + +!Morph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:20:05'! +isOwnedByWorld + ^owner is: #OldPasteUpMorph! ! + + +!OldPasteUpMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:20:05'! +is: aSymbol + ^ aSymbol == #OldPasteUpMorph or: [ super is: aSymbol ]! ! + + +!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 16:20:05'! +activeSubclass: aMorphicCanvasSubclass + ActiveSubclass _ aMorphicCanvasSubclass. + OldPasteUpMorph allInstancesDo: [ :w | w setCanvas ]! ! + + +!SystemDictionary reorganize! +('accessing' classes description name organization summary) +('class names' classNamed: fillCaches flushClassNameCache forgetClass:logged: hasClassNamed: prepareToRenameClass:as: prepareToRenameClass:from:to: removeClassNamed: removeClassNamedIfInBaseSystem: renameAndUpdateReferences:as: renameClassNamed:as: renamedClass:from:) +('dictionary access' associationOrUndeclaredAt: at:put:) +('housekeeping' browseEqEqSentToSmallIntegerConstants browseObsoleteMethodReferences browseUndeclaredReferences cleanCompactObsoleteClasses cleanOutUndeclared condenseChanges condenseSources macroBenchmark1 macroBenchmark3 obsoleteBehaviors obsoleteClasses obsoleteMethodReferences recompileAllFrom: removeEmptyMessageCategories testDecompiler testFormatter testFormatter2 verifyChanges) +('image, changes name' alternativeSourcesName changeImageNameTo: currentChangesName currentSourcesName defaultChangesName defaultSourcesName defaultUserChangesName fullNameForChangesNamed: fullNameForImageNamed: imageName imageName: imagePath primImageName primVmPath vmPath) +('memory space' bytesLeft bytesLeft: bytesLeftString createStackOverflow garbageCollect garbageCollectMost growMemoryByAtLeast: installLowSpaceWatcher lowSpaceThreshold lowSpaceWatcher lowSpaceWatcherProcess okayToProceedEvenIfSpaceIsLow primBytesLeft primLowSpaceSemaphore: primSignalAtBytesLeft: primitiveGarbageCollect signalLowSpace stopLowSpaceWatcher useUpMemory useUpMemoryWithArrays useUpMemoryWithContexts useUpMemoryWithTinyObjects) +('code authors' allContributors contributionsOf: knownInitialsAndNames unknownContributors) +('miscellaneous' cogitClass exitToDebugger extraVMMemory extraVMMemory: getCurrentWorkingDirectory getSystemAttribute: getVMParameters handleUserInterrupt interpreterClass isDevelopmentEnvironmentPresent isHeadless listBuiltinModule: listBuiltinModules listLoadedModule: listLoadedModules logError:inContext:to: maxExternalSemaphores maxExternalSemaphores: osVersion platformName platformSubtype primGetCurrentWorkingDirectoryUnix primGetCurrentWorkingDirectoryWindows primVmFileName unloadModule: vmFileName vmOptionsDo: vmVersion voidCogVMState) +('object serialization' objectForDataStream: storeDataOn:) +('printing' printElementsOn: printOn:) +('profiling' clearProfile dumpProfile profile: startProfiling stopProfiling) +('retrieving' allBehaviorsDo: allCallsOn: allCallsOn:and: allClasses allClassesDo: allClassesImplementing: allGlobalRefs allGlobalRefsWithout: allImplementedMessages allImplementedMessagesWithout: allImplementorsOf: allImplementorsOf:localTo: allMethodsInCategory: allMethodsSourceStringMatching: allMethodsWithSourceString:matchCase: allMethodsWithString: allObjects allObjectsDo: allObjectsOrNil allPrimitiveMessages allPrimitiveMethodsInCategories: allReferencesToLiteral: allSelect: allSentMessages allSentMessagesWithout: allUnSentMessages allUnSentMessagesIn: allUnSentMessagesWithout: allUnimplementedCalls allUnusedClassesWithout: hierachySortedAllClassesDo: isThereAReferenceTo: isThereAnImplementorOf: isThereAnImplementorOf:exceptFor: numberOfImplementorsOf: numberOfSendersOf: pointersTo: pointersTo:except: poolUsers unimplemented) +('shrinking' abandonSources presumedSentMessages reduceCuis removeAllUnSentMessages removeSelector: removedUnusedClassesAndMethods reportClassAndMethodRemovalsFor: unusedClasses unusedClassesAndMethodsWithout:) +('snapshot and quit' add:toList:after: addToShutDownList: addToShutDownList:after: addToStartUpList: addToStartUpList:after: lastQuitLogPosition logSnapshot:andQuit: nopTag okayToDiscardUnsavedCode okayToSave printStuffToCleanOnImageSave processShutDownList: processStartUpList: quitNoSaveTag quitPrimitive quitPrimitive: quitTag removeFromShutDownList: removeFromStartUpList: saveAs saveAs:andQuit:clearAllClassState: saveAsNewVersion saveSession send:toClassesNamedIn:with: setGCParameters setPlatformPreferences snapshot:andQuit: snapshot:andQuit:clearAllClassState: snapshot:andQuit:embedded: snapshot:andQuit:embedded:clearAllClassState: snapshotEmbeddedPrimitive snapshotMessageFor:andQuit: snapshotPrimitive snapshotTag snapshotTagFor:andQuit: storeOn: tagHeader tagTail unbindExternalPrimitives) +('sources, change log' aboutThisSystem assureStartupStampLogged calcEndianness classRemoved:fromCategory: closeSourceFiles endianness evaluated:context: externalizeSources forceChangesToDisk internalizeChangeLog internalizeSources isBigEndian isLittleEndian lastUpdateString logChange: logChange:preamble: methodRemoved:selector:inProtocol:class: openSourceFiles openSourcesAndChanges systemInformationString timeStamp: version) +('special objects' clearExternalObjects compactClassesArray compactClassesArrayIncludes: externalObjects hasSpecialSelector:ifTrueSetByte: primitiveErrorTable recreateSpecialObjectsArray registerExternalObject: specialNargsAt: specialObjectsArray specialSelectorAt: specialSelectorSize specialSelectors unregisterExternalObject:) +('toDeprecate') +('ui' beep confirmRemovalOf:on: globals inspectGlobals primitiveBeep systemCategoryFromUserWithPrompt:) +('browsing' browseAllAccessesTo:from: browseAllCallsOn: browseAllCallsOn:and: browseAllCallsOn:localTo: browseAllCallsOnClass: browseAllImplementorsOf: browseAllImplementorsOf:localTo: browseAllImplementorsOfList: browseAllImplementorsOfList:title: browseAllMethodsInCategory: browseAllPrimitives browseAllReferencesToLiteral: browseAllSelect: browseAllSelect:name:autoSelect: browseAllStoresInto:from: browseAllUnSentMessages browseAllUnimplementedCalls browseClassCommentsWithString: browseClassesWithNamesContaining:caseSensitive: browseEqSmallConstant browseInstVarDefs: browseInstVarRefs: browseLikelyUnnededRedefinitions browseMessageList:name: browseMessageList:name:autoSelect: browseMessageList:ofSize:name:autoSelect: browseMethodsWithSourceString: browseMethodsWithString: browseMethodsWithString:matchCase: browseMyChanges browseObsoleteReferences browseViewReferencesFromNonViews showMenuOf:withFirstItem:ifChosenDo: showMenuOf:withFirstItem:ifChosenDo:withCaption:) +('private' allSymbolsIn:do: baseLabel) +('Closure measurements' browseMethodsWithClosuresThatAccessOuterTemps browseMethodsWithClosuresThatOnlyReadOuterTemps browseMethodsWithClosuresThatWriteOuterTemps browseMethodsWithClosuresThatWriteOuterTempsButCleanOtherwise browseMethodsWithEmptyClosures browseMethodsWithMoreThanOneClosure browseMethodsWithOnlyCleanClosures closuresInfoStringForClass:selector: eliotsClosureMeasurements eliotsClosureMeasurements2 eliotsClosureMeasurements2On: eliotsClosureMeasurementsOn:over:) +('removing' removeKey:ifAbsent:) +('system attributes' flagInterpretedMethods: isRunningCog isRunningCogit isSpur maxIdentityHash processHasThreadIdInstVar: processPreemptionYields processPreemptionYields:) +('query' hierarchySorted:do: methodsWithUnboundGlobals unusedBlocks) +('testing' hasBindingThatBeginsWith: isLiveSmalltalkImage isLiveTypingInstalled) +('classes and traits' classNames nonClassNames) +('image format' imageFormatVersion imageFormatVersionFromFile imageFormatVersionFromFileAsIs) +('AndreasProfiler-profiling' interruptChecksPerMSec longRunningPrimitive longRunningPrimitiveSemaphore: profilePrimitive profileSample profileSemaphore: profileStart:) +('startup' doStartUp: processCommandLineArgument:storeStartUpScriptArgsOn: processCommandLineArguments readCommandLineArguments setStartupStamp startUpArguments startUpScriptArguments) +('startup - restore lost changes' hasToRestoreChanges hasToRestoreChangesFrom: isQuitNoSaveRecord: isQuitRecord: isSnapshotQuitOrQuitNoSaveRecord: isSnapshotRecord: lostChangesDetectedCaption restoreLostChanges restoreLostChangesAutomatically restoreLostChangesAutomaticallyFrom: restoreLostChangesIfNecessary restoreLostChangesManually restoreLostChangesOptions restoringChangesHasErrorsCaption shouldShowFileInErrors withChangesFileDo:) +('image' wordSize) +('vm parameters' doMixedArithmetic doMixedArithmetic: vmParameterAt: vmParameterAt:put:) +! + + +!Morph reorganize! +('accessing' adoptWidgetsColor: beSticky color location lock morphId resistsRemoval taskbar toggleStickiness unlock unlockContents) +('accessing - flags' isLayoutNeeded isRedrawNeeded isSubmorphRedrawNeeded layoutNeeded: needsRedraw: submorphNeedsRedraw: visible) +('accessing - properties' hasProperty: isLocked isSticky lock: name name: removeProperty: setProperty:toValue: sticky: valueOfProperty: valueOfProperty:ifAbsent: valueOfProperty:ifPresentDo:) +('as yet unclassified' canDiscardEdits disregardUnacceptedEdits rotationDegrees: whenUIinSafeState:) +('caching' clearId fullReleaseCachedState releaseCachedState) +('change reporting' addedMorph: invalidateDisplayRect:fromSubmorph:for: invalidateLocalRect:) +('classification' isWorldMorph) +('copying' copy copyForClipboard duplicate) +('debug and other' addDebuggingItemsTo:hand: buildDebugMenu: inspectOwnerChain ownerChain resumeAfterDrawError resumeAfterStepError) +('drawing' addPossiblyUncoveredAreasIn:to: drawOn: drawingFails drawingFailsNot hide icon imageForm: imageForm:depth: isKnownFailing refreshWorld show visible:) +('dropping/grabbing' aboutToBeGrabbedBy: aboutToGrab: acceptDroppingMorph:event: dropFiles: justDroppedInto:event: justGrabbedFrom: rejectDropMorphEvent: wantsDroppedMorph:event: wantsToBeDroppedInto:) +('e-toy support' embeddedInMorphicWindowLabeled: unlockOneSubpart wantsRecolorHandle) +('events' click:localPosition: doubleClick:localPosition: dragEvent:localPosition: keyDown: keyStroke: keyUp: mouseButton1Down:localPosition: mouseButton1Up:localPosition: mouseButton2Down:localPosition: mouseButton2Up:localPosition: mouseButton3Down:localPosition: mouseButton3Up:localPosition: mouseEnter: mouseHover:localPosition: mouseLeave: mouseMove:localPosition: mouseScroll:localPosition: mouseStillDown windowEvent:) +('event handling testing' allowsFilesDrop allowsMorphDrop allowsSubmorphDrag handlesKeyboard handlesMouseDown: handlesMouseHover handlesMouseOver: handlesMouseScroll: handlesMouseStillDown:) +('event handling' mouseButton2Activity mouseStillDownStepRate mouseStillDownThreshold) +('events-alarms' addAlarm:after: addAlarm:with:after: addAlarm:withArguments:after: alarmScheduler removeAlarm:) +('events-processing' dispatchEvent:localPosition: focusKeyboardFor: handleFocusEvent: processDropFiles:localPosition: processDropMorph:localPosition: processKeyDown:localPosition: processKeyUp:localPosition: processKeystroke:localPosition: processMouseDown:localPosition: processMouseEnter:localPosition: processMouseLeave:localPosition: processMouseMove:localPosition: processMouseOver:localPosition: processMouseScroll:localPosition: processMouseStillDown processMouseUp:localPosition: processUnknownEvent:localPosition: processWindowEvent:localPosition: rejectsEvent: rejectsEventFully:) +('fileIn/out' prepareToBeSaved storeDataOn:) +('focus handling' hasKeyboardFocus hasMouseFocus keyboardFocusChange:) +('geometry' allocHeightForFactor: allocWidthForFactor: displayBounds displayBounds: displayBoundsForHalo displayBoundsOrBogus displayFullBounds extentBorder externalize: externalizeDisplayBounds: externalizeDistance: externalizeDistanceToWorld: externalizeToWorld: fontPreferenceChanged internalize: internalizeDistance: internalizeDistanceFromWorld: internalizeFromWorld: minimumExtent minimumLayoutExtent morphAlign:with: morphExtent morphExtent: morphExtentInWorld morphExtentInWorld: morphHeight morphLocalBounds morphPosition morphPosition: morphPositionInWorld morphPositionInWorld: morphTopLeft morphWidth rotateBy: rotation: rotation:scale: scaleBy:) +('geometry eToy' referencePosition referencePosition:) +('geometry testing' clipsLastSubmorph fullContainsGlobalPoint: fullContainsPoint: isOrthoRectangularMorph morphContainsPoint: requiresVectorCanvas submorphsMightProtrude) +('halos and balloon help' addHalo addHalo: addHandlesTo:box: addOptionalHandlesTo:box: balloonHelpDelayTime balloonText comeToFrontAndAddHalo deleteBalloon editBalloonHelpContent: editBalloonHelpText halo mouseDownOnHelpHandle: noHelpString okayToBrownDragEasily okayToResizeEasily okayToRotateEasily removeHalo setBalloonText: showBalloon: showBalloon:hand: transferHalo:from: wantsBalloon wantsHalo wantsHaloHandleWithSelector:inHalo:) +('initialization' inATwoWayScrollPane initialize intoWorld: openInHand openInWorld openInWorld:) +('iteration of all morphs' nextMorph nextMorphPart2 nextMorphThat: previousMorph previousMorphThat:) +('layout' layoutSubmorphs layoutSubmorphsIfNeeded minItemWidth minimumLayoutHeight minimumLayoutWidth minimumShrinkExtent minimumShrinkHeight minimumShrinkWidth someSubmorphPositionOrExtentChanged) +('layout-properties' layoutSpec layoutSpec: layoutSpecOrNil) +('macpal' flash flashWith:) +('menus' addAddHandMenuItemsForHalo:hand: addColorMenuItems:hand: addCopyItemsTo: addCustomHaloMenuItems:hand: addCustomMenuItems:hand: addExportMenuItems:hand: addHaloActionsTo: addStandardHaloMenuItemsTo:hand: addTitleForHaloMenu: addToggleItemsToHaloMenu: changeColor expand exportAsBMP exportAsJPEG lockUnlockMorph lockedString maybeAddCollapseItemTo: stickinessString) +('meta-actions' addEmbeddingMenuItemsTo:hand: buildHandleMenu: copyToClipboard: dismissMorph duplicateMorph: maybeDuplicateMorph potentialEmbeddingTargets) +('naming' label) +('object serialization' objectForDataStream:) +('player' okayToDuplicate) +('printing' printOn:) +('rotate scale and flex' rotationDegrees) +('stepping' shouldGetStepsFrom: startStepping startStepping: startStepping:in:stepTime: startStepping:stepTime: startSteppingStepTime: step stepAt: stopStepping stopStepping: wantsSteps) +('structure' allOwnersDo: allOwnersReverseDo: firstOwnerSuchThat: hasOwner: isInWorld owner owningWindow root veryLastLeaf withAllOwnersDo: withAllOwnersReverseDo: world) +('submorphs-accessing' allMorphsDo: clippedSubmorph findDeepSubmorphThat:ifAbsent: findSubmorphBinary: firstSubmorph hasSubmorphs lastSubmorph noteNewOwner: submorphBehind: submorphCount submorphInFrontOf: submorphs submorphsBehind:do: submorphsDo: submorphsDrawingOutsideReverseDo: submorphsInFrontOf:do: submorphsReverseDo: submorphsSatisfying: unclippedSubmorphsReverseDo:) +('submorphs-add/remove' addAllMorphs: addAllMorphs:after: addMorph: addMorph:behind: addMorph:inFrontOf: addMorph:position: addMorphBack: addMorphBack:position: addMorphFront: addMorphFront:position: addMorphFrontFromWorldPosition: atFront canAdd: comeToFront delete dismissViaHalo goBehind privateDelete removeAllMorphs removeAllMorphsIn: removeMorph: removedMorph: replaceSubmorph:by:) +('testing' hasModel is: isCollapsed isOwnedByHand isOwnedByWorld isProportionalHeight isProportionalWidth isReallyVisible stepTime) +('updating' invalidateBounds redrawNeeded) +('user interface' activateWindow activateWindowAndSendTopToBack: collapse showAndComeToFront toggleCollapseOrShow) +('private' privateAddAllMorphs:atIndex: privateAddMorph:atIndex: privateAddMorph:atIndex:position: privateAnyOwnerHandlesMouseScroll: privateFlagAt: privateFlagAt:put: privateMoveBackMorph: privateMoveFrontMorph: privateOwner: privatePosition: privateRemove: privateSubmorphs) +('previewing' beginPreview endPreview endPreviewAndToggleCollapseOrShow morphBehindBeforePreview morphBehindBeforePreview: previewing previewing: visibleBeforePreview visibleBeforePreview:) +! + + +!OldPasteUpMorph reorganize! +('accessing' activeHand color: handlesKeyboard) +('alarms-scheduler' addAlarm:withArguments:for:at: removeAlarm:for:) +('caching' releaseCachedState) +('change reporting' addedMorph: invalidateDisplayRect:fromSubmorph:for: removedMorph:) +('classification' isWorldMorph) +('drawing' drawOn:) +('dropping/grabbing' allowsFilesDrop allowsMorphDrop allowsSubmorphDrag dropFiles:) +('errors on draw' addKnownFailing: isKnownFailing: removeAllKnownFailing removeKnownFailing:) +('events' click:localPosition: keyStroke: mouseButton1Down:localPosition: windowEvent:) +('event handling testing' handlesMouseDown:) +('event handling' mouseButton2Activity wantsWindowEvent: windowEventHandler) +('geometry' displayBounds externalizeDisplayBounds: externalizeToWorld: fontPreferenceChanged internalizeFromWorld: morphPositionInWorld privateExtent:) +('initialization' clearCanvas clearWaitDelay defaultBorderColor defaultBorderWidth defaultColor setCanvas) +('interaction loop' doOneCycleNow mainLoop runProcess) +('menu & halo' addCustomMenuItems:hand: addWorldHaloMenuItemsTo:hand: deleteBalloonTarget:) +('misc' backgroundImage backgroundImageData: buildMagnifiedBackgroundImage) +('printing' printOn:) +('project state' canvas firstHand hands handsDo: handsReverseDo: setCanvas: viewBox) +('stepping' startStepping:at:selector:stepTime: stopStepping:selector: stopSteppingMorph:) +('stepping and presenter' wantsSteps) +('structure' world) +('submorphs-accessing' allMorphsDo:) +('submorphs-add/remove' addMorph:centeredNear: canHandle:) +('testing' is: isReallyVisible stepTime) +('world menu' bringWindowsFullOnscreen closeUnchangedWindows collapseAll collapseNonWindows deleteNonWindows findAChangeSorter: findAFileList: findAMessageNamesWindow: findATranscript: findAWindowSatisfying:orMakeOneUsing: findDirtyBrowsers: findDirtyWindows: findWindow: invokeWorldMenu restoreAll) +('world state' allNonWindowRelatedSubmorphs deleteAllHalos displayWorld displayWorldSafely doOneCycle doOneMinimalCycleNow fillRects: fullRepaintNeeded haloMorphs privateOuterDisplayWorld restoreDisplay whenUIinSafeState: worldState:) +('halos and balloon help' wantsHaloHandleWithSelector:inHalo:) +('object serialization' objectForDataStream:) +('windows' findATranscript) +('taskbar' hideTaskbar showTaskbar taskbar taskbarDeleted) +('defaul desktop' recreateDefaultDesktop tearDownDesktop) +('ui services' request:initialAnswer:orCancel: request:initialAnswer:verifying:do:orCancel:) +! + + +!MorphicCanvas class reorganize! +('instance creation' activeSubclass activeSubclass: depth:over: on:over: onForm: subclassToUse withExtent:depth:) +! + diff --git a/CoreUpdates/4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st b/CoreUpdates/4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st new file mode 100644 index 00000000..150d96fd --- /dev/null +++ b/CoreUpdates/4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st @@ -0,0 +1,1484 @@ +'From Cuis 5.0 [latest update: #4416] on 21 October 2020 at 5:18:31 pm'! +!classDefinition: #PasteUpMorph category: #'Morphic-Kernel'! +KernelMorph subclass: #PasteUpMorph + instanceVariableNames: 'backgroundImage backgroundImageData' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Kernel'! + +!PasteUpMorph commentStamp: 'jmv 2/21/2016 18:32' prior: 0! +A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu. + +worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. +! + +!classDefinition: #WorldMorph category: #'Morphic-Kernel'! +PasteUpMorph subclass: #WorldMorph + instanceVariableNames: 'activeHand hands canvas damageRecorder stepList lastCycleTime alarms lastAlarmTime deferredUIMessages drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent taskbar' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Kernel'! + +!WorldMorph commentStamp: '' prior: 0! +A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. + +activeHand -- a HandMorph +hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. +canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) +damageRecorder -- the DamageRecorder for the Display +stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. + See comment in #Morph>>stepAt: +lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) +lastStepMessage -- nil or a selector +lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) +alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: + An _alarm_ is an action to be done once, vs a _step_ which is cycled. +lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). +drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures +waitDelay -- a Delay (set in #WorldState>>doOneCycleFor:) +pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. + (set in #WorldState>>doOneCycleFor:) +lastCycleHadAnyEvent -- a boolean (set in #WorldState>>doOneCycleFor:) +world -- a PasteUpMorph +! + + +!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 10/21/2020 16:24:51'! +activeHand + "Answer the currently active hand, if any..." + ^self world ifNotNil: [ :w | w activeHand ]! ! + +!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 11/19/2010 13:56'! +color: aColor + super color: aColor. + self backgroundImageData: nil! ! + +!PasteUpMorph methodsFor: 'accessing' stamp: 'GC 3/17/2019 08:16:08'! +handlesKeyboard + + ^ true ! ! + +!PasteUpMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 16:44:28'! +releaseCachedState + super releaseCachedState. + backgroundImage _ nil.! ! + +!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:14'! +addedMorph: aMorph + "Notify the receiver that the given morph was just added." + super addedMorph: aMorph. + self taskbar ifNotNil: [ :tb | + tb wasOpened: aMorph ]! ! + +!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:07'! +removedMorph: aMorph + "Notify the receiver that aMorph was just removed from its children" + super removedMorph: aMorph. + self taskbar ifNotNil: [ :tb | + tb wasDeleted: aMorph ]! ! + +!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:40:25'! +drawOn: aCanvas + + "draw background image." + backgroundImage + ifNotNil: [ + aCanvas image: backgroundImage at: `0@0` ] + ifNil: [ + super drawOn: aCanvas ]! ! + +!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 07:13:56'! +allowsFilesDrop + + ^ true! ! + +!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:24'! +allowsMorphDrop + "Answer whether we accept dropping morphs. By default answer false." + + ^ true! ! + +!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:25'! +allowsSubmorphDrag + "Answer whether our morphs can just be grabbed with the hand, instead of requiring the use of the halo. By default answer false. + Both 'aMorph allowsGrabWithHand' and 'aMorph owner allowsSubmorphDrag' must be true for aMorph to be grabbed by the hand. It is also required that 'aMorph handlesMouseDown:' be false." + + ^ true! ! + +!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 10:27:39'! +dropFiles: aDropFilesEvent + + (DropFilesAction for: aDropFilesEvent) value! ! + +!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/28/2019 18:13:11'! +keyStroke: aKeyboardEvent + "Handle a keystroke event." + (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) + ifTrue: [ + aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. + aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. + aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. + ]. + "aKeyboardEvent keyCharacter print." + ^ super keyStroke: aKeyboardEvent! ! + +!PasteUpMorph methodsFor: 'events' stamp: 'jmv 1/18/2013 12:38'! +mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition + "Handle a mouse down event." + + super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. + + aMouseButtonEvent hand + waitForClicksOrDragOrSimulatedMouseButton2: self + event: aMouseButtonEvent + clkSel: #click:localPosition: + clkNHalf: nil + dblClkSel: #doubleClick:localPosition: + dblClkNHalfSel: nil + tripleClkSel: nil! ! + +!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 15:41:41'! +windowEvent: aMorphicEvent + + aMorphicEvent windowEventType == #windowClose + ifTrue: [ + ^TheWorldMenu basicNew quitSession] +! ! + +!PasteUpMorph methodsFor: 'event handling testing' stamp: 'jmv 8/20/2012 18:56'! +handlesMouseDown: aMouseButtonEvent + ^true! ! + +!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 3/10/2011 16:02'! +mouseButton2Activity + + ^self invokeWorldMenu! ! + +!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:08'! +wantsWindowEvent: anEvent + ^false! ! + +!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 5/24/2020 10:07:38'! +fontPreferenceChanged + self submorphsDo: [ :m | + m morphExtent: (m morphExtent max: m minimumExtent). + m fontPreferenceChanged ]! ! + +!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:33:43'! +privateExtent: newExtent + + ^ (super privateExtent: newExtent) + ifTrue: [ self buildMagnifiedBackgroundImage ]; + yourself! ! + +!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:35'! +defaultBorderColor + "answer the default border color/fill style for the receiver" + ^ `Color + r: 0.861 + g: 1.0 + b: 0.722`! ! + +!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! +defaultBorderWidth + "answer the default border width for the receiver" + ^ 1! ! + +!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:44'! +defaultColor + "answer the default color/fill style for the receiver" + ^ `Color + r: 0.8 + g: 1.0 + b: 0.6`! ! + +!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 8/17/2020 13:41:37'! +mainLoop + + + self clearWaitDelay. + self setCanvas. + [ + self doOneCycle. + Processor yield. + true ] + whileTrue: []! ! + +!PasteUpMorph methodsFor: 'interaction loop' stamp: 'HAW 12/26/2019 10:05:45'! +runProcess + + | process | + + process _ [ self mainLoop ] newProcess. + process + priority: Processor userSchedulingPriority; + name: 'Morphic UI'; + animatedUI: self. + + ^ process! ! + +!PasteUpMorph methodsFor: 'menu & halo' stamp: 'jmv 1/19/2013 15:14'! +addWorldHaloMenuItemsTo: aMenu hand: aHandMorph + "Add standard halo items to the menu, given that the receiver is a World" + + | unlockables | + self addColorMenuItems: aMenu hand: aHandMorph. + +" aMenu addLine. + self addWorldToggleItemsToHaloMenu: aMenu." + aMenu addLine. + self addCopyItemsTo: aMenu. + self addExportMenuItems: aMenu hand: aHandMorph. + + self addDebuggingItemsTo: aMenu hand: aHandMorph. + + aMenu addLine. + aMenu defaultTarget: self. + + aMenu addLine. + + unlockables _ self submorphs select: + [ :m | m isLocked]. + unlockables size = 1 ifTrue: [ + aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. + unlockables size > 1 ifTrue: [ + aMenu add: 'unlock all contents' action: #unlockContents. + aMenu add: 'unlock...' action: #unlockOneSubpart]. + + aMenu defaultTarget: aHandMorph. +! ! + +!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 3/2/2011 11:10'! +backgroundImage + ^backgroundImage! ! + +!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 12/8/2013 15:11'! +backgroundImageData: aByteArray + " + | filename | + filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. + filename _ 'bg/free-desktop-wallpaper.jpg'. + filename _ 'bg/jellyfish-thumb.jpg'. + filename _ 'bg/splash_by_beefpepsi.jpg'. + filename _ 'bg/gray ocean and pier.jpg'. + filename _ 'bg/newyork.jpg'. + filename _ 'bg/download-free-desktop-wallpaper-nature-conquestofparadise-marirs-pic.jpg'. + filename _ 'bg/desktop-wallpaper-tropical-1280x1024.jpg'. + + filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. + self runningWorld backgroundImageData: (FileStream readOnlyFileNamed: filename) binary contentsOfEntireFile. + " + backgroundImageData _ aByteArray. + self buildMagnifiedBackgroundImage! ! + +!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:30:09'! +buildMagnifiedBackgroundImage + | image old | + old _ backgroundImage. + backgroundImageData + ifNil: [ backgroundImage _ nil ] + ifNotNil: [ + [image _ Form fromBinaryStream: backgroundImageData readStream. + backgroundImage _ image magnifyTo: extent. + ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" + ]. + old == backgroundImage ifFalse: [ + self redrawNeeded ]! ! + +!PasteUpMorph methodsFor: 'stepping and presenter' stamp: 'jmv 6/11/2012 09:59'! +wantsSteps + "Return true if the receiver wants to its #step or #stepAt: methods be run ALL THE TIME. + Morphs that send #startStepping and #stopStepping at appropriate times (i.e. when they are already in the world!!) don't need to answer true to this message. + jmv: Not really sure. Sub-world stepping needs some review." + + ^true! ! + +!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 14:47:46'! +addMorph: aMorph centeredNear: aPoint + "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." + + | trialRect delta | + trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. + delta _ trialRect amountToTranslateWithin: self displayBounds. + self addMorph: aMorph. + aMorph morphPositionInWorld: trialRect origin + delta.! ! + +!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 3/9/2020 10:13:47'! +is: aSymbol + ^ aSymbol == #PasteUpMorph or: [ super is: aSymbol ]! ! + +!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:42:59'! +isReallyVisible + "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" + ^self visible and: [owner isReallyVisible ]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:17'! +bringWindowsFullOnscreen + "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." + (SystemWindow + windowsIn: self + satisfying: [ :w | + w visible ]) do: [ :each | + each makeMeFullyVisible ]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:18'! +closeUnchangedWindows + "Present a menu of window titles for all windows with changes, + and activate the one that gets chosen." + (SelectionMenu confirm: 'Do you really want to close all windows +except those with unaccepted edits?') ifFalse: [ ^ self ]. + (SystemWindow + windowsIn: self + satisfying: [ :w | + w visible and: [ w canDiscardEdits ]]) do: [ :w | + w delete ]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58'! +collapseNonWindows + self allNonWindowRelatedSubmorphs do: [ :m | + m collapse]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58'! +deleteNonWindows + (SelectionMenu confirm: +'Do you really want to discard all objects +that are not in windows?') + ifFalse: [^ self]. + + self allNonWindowRelatedSubmorphs do: [:m | + m delete ]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/21/2012 17:23'! +findAChangeSorter: evt + "Locate a change sorter, open it, and bring it to the front. Create one if necessary" + self + findAWindowSatisfying: [ :aWindow | + aWindow model isMemberOf: ChangeSorter] + orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:20'! +findAFileList: evt + "Locate a file list, open it, and bring it to the front. + Create one if necessary, respecting the Preference." + self + findAWindowSatisfying: [ :aWindow | + aWindow model class == FileList ] + orMakeOneUsing: [ + FileListWindow openFileList ]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:21'! +findAMessageNamesWindow: evt + "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" + self + findAWindowSatisfying: [ :aWindow | + aWindow model class == MessageNames ] + orMakeOneUsing: [ + MessageNamesWindow open: MessageNames new label: 'Message Names' ]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/30/2014 09:01'! +findATranscript: evt + "Locate a transcript, open it, and bring it to the front. Create one if necessary" + + self findATranscript! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 10/25/2010 21:29'! +findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock + "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" + | aWindow | + submorphs do: [ :aMorph | + (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ + aWindow isCollapsed ifTrue: [ aWindow expand ]. + aWindow activateAndForceLabelToShow. + ^ self ]]. + "None found, so create one" + makeBlock value.! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/5/2016 09:42'! +findDirtyBrowsers: evt + "Present a menu of window titles for browsers with changes, + and activate the one that gets chosen." + | menu | + menu _ MenuMorph new. + (SystemWindow + windowsIn: self + satisfying: [ :w | + w visible and: [ + (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | + menu + add: w label + target: w + action: #activate ]. + menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:20'! +findDirtyWindows: evt + "Present a menu of window titles for all windows with changes, + and activate the one that gets chosen." + | menu | + menu _ MenuMorph new. + (SystemWindow + windowsIn: self + satisfying: [ :w | + w visible and: [ w canDiscardEdits not ]]) do: [ :w | + menu + add: w label + target: w + action: #activate ]. + menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/10/2018 22:02:53'! +findWindow: evt + "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." + | menu expanded collapsed nakedMorphs | + menu _ MenuMorph new. + expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. + collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. + nakedMorphs _ self submorphsSatisfying: [ :m | + (m is: #SystemWindow) not ]. + expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. + (expanded asArray sort: [ :w1 :w2 | + w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | + menu + add: w label + target: w + action: #activateAndForceLabelToShow. + w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. + expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. + (collapsed asArray sort: [ :w1 :w2 | + w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | + menu + add: w label + target: w + action: #expand. + w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. + nakedMorphs isEmpty ifFalse: [ menu addLine ]. + (nakedMorphs asArray sort: [ :w1 :w2 | + w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | + menu + add: w label + target: w + action: #comeToFrontAndAddHalo ]. + menu addTitle: 'find window'. + menu popUpInWorld: self! ! + +!PasteUpMorph methodsFor: 'world menu' stamp: 'HAW 7/5/2018 18:24:37'! +invokeWorldMenu + "Put up the world menu, triggered by the passed-in event. + Perhaps a good place to disable it if needed" + + | menu | + menu _ (TheWorldMenu new + world: self + hand: self activeHand) buildWorldMenu. + menu addTitle: Preferences desktopMenuTitle. + menu popUpInWorld: self! ! + +!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/8/2017 16:44:57'! +allNonWindowRelatedSubmorphs + "Answer all non-window submorphs that are not flap-related" + + ^submorphs + reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! + +!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 2/28/2011 15:16'! +deleteAllHalos + self haloMorphs do: + [ :m | m delete]! ! + +!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 9/13/2013 09:18'! +fullRepaintNeeded + self redrawNeeded. + SystemWindow + windowsIn: self + satisfying: [ :w | + w visible ifTrue: [ w makeMeVisible ]. + false ]! ! + +!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 18:00'! +haloMorphs + ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! ! + +!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:33'! +wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph + "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" + (#(addHelpHandle: addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) + ifTrue: ["FIXME - hack to disable for non-functional halo items" + ^ false]. + + ^super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph! ! + +!PasteUpMorph methodsFor: 'object serialization' stamp: 'jmv 6/8/2014 18:28'! +objectForDataStream: refStrm + "I am about to be written on an object file. Write a path to me in the other system instead." + + | dp | + dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). + refStrm replace: self with: dp. + ^ dp! ! + +!PasteUpMorph methodsFor: 'windows' stamp: 'jmv 7/30/2014 09:00'! +findATranscript + "Locate a transcript, open it, and bring it to the front. Create one if necessary" + + self + findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] + orMakeOneUsing: [ TranscriptWindow openTranscript ]! ! + +!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:01'! +request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock + "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." + ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! + +!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:05'! +request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock + ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! + + +!PasteUpMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:47'! +initClassCachedState + "Should use some other way to find relevant instances" + self flag: #jmvVer2. + self allInstancesDo: [ :each | + each buildMagnifiedBackgroundImage ]. + Cursor defaultCursor activateCursor.! ! + +!PasteUpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:51:39'! +categoryInNewMorphMenu + ^ 'Worlds'! ! + + +!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:33:59'! +addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime + "Add a new alarm with the given set of parameters" + + alarms add: + (MorphicAlarm + receiver: aTarget + selector: aSelector + arguments: argArray + at: scheduledTime)! ! + +!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:03'! +adjustAlarmTimes: nowTime + "Adjust the alarm times after some clock weirdness (such as image-startup etc)" + | deltaTime | + deltaTime _ nowTime - lastAlarmTime. + alarms do: [ :alarm | + alarm scheduledTime: alarm scheduledTime + deltaTime ]! ! + +!WorldMorph methodsFor: 'alarms' stamp: 'jmv 5/11/2016 09:53'! +alarmSortBlock + + ^[ :alarm1 :alarm2 | alarm1 scheduledTime < alarm2 scheduledTime ]! ! + +!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 11:54:00'! +removeAlarm: aSelector for: aTarget + "Remove the alarm with the given selector" + + | alarm | + alarm _ alarms + detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] + ifNone: nil. + alarm ifNotNil: [ alarms remove: alarm ]! ! + +!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:35:03'! +triggerAlarmsBefore: nowTime + "Trigger all pending alarms that are to be executed before nowTime." + + nowTime - lastAlarmTime > 10000 + ifTrue: [ self adjustAlarmTimes: nowTime ]. + [ alarms notEmpty and: [ alarms first scheduledTime < nowTime ]] + whileTrue: [ alarms removeFirst valueAtTime: nowTime ]. + lastAlarmTime _ nowTime! ! + +!WorldMorph methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'! +canvas + + ^ canvas! ! + +!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/17/2020 13:42:46'! +clearCanvas + canvas _ nil. + damageRecorder _ nil.! ! + +!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:06'! +ensureNonDisplayCanvas + (canvas isNil or: [ + canvas drawsOnDisplay or: [ + (canvas extent ~= self morphExtent) or: [ + canvas form depth ~= Display depth]]]) ifTrue: [ + "allocate a new offscreen canvas the size of the window" + self setCanvas: (MorphicCanvas withExtent: self morphExtent depth: Display depth)]! ! + +!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/4/2020 10:02:25'! +recordDamagedRect: damageRect for: aMorph + + damageRecorder ifNotNil: [ + damageRecorder recordInvalidRect: damageRect for: aMorph ]! ! + +!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:17'! +setCanvas + self setCanvas: Display getCanvas. + damageRecorder _ DamageRecorder new. + self redrawNeeded! ! + +!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:24'! +setCanvas: aMorphicCanvas + canvas _ aMorphicCanvas. + canvas world: self. + damageRecorder + ifNil: [ damageRecorder _ DamageRecorder new].! ! + +!WorldMorph methodsFor: 'hands' stamp: 'jmv 9/25/2012 22:39'! +activeHand + ^activeHand! ! + +!WorldMorph methodsFor: 'hands' stamp: 'di 6/7/1999 17:40'! +hands + + ^ hands! ! + +!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 10:13'! +handsDo: aBlock + + ^ hands do: aBlock! ! + +!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:09'! +handsReverseDo: aBlock + + ^ hands reverseDo: aBlock! ! + +!WorldMorph methodsFor: 'hands' stamp: 'jmv 7/22/2020 20:42:49'! +selectHandsToDrawForDamage: damageList + "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." + + | result | + result _ OrderedCollection new. + hands do: [:hand | + hand needsToBeDrawn ifTrue: [ + hand hasChanged + ifTrue: [result add: hand] + ifFalse: [ + hand displayFullBounds ifNotNil: [ :handBounds | + (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ + result add: hand]]]]]. + ^ result! ! + +!WorldMorph methodsFor: 'initialization' stamp: 'jmv 6/20/2014 20:24:55'! +clearWaitDelay + waitDelay ifNotNil: [ + waitDelay unschedule. + waitDelay _ nil ]. + "Needed if for some reason Cuis is started with an earlier DateTime than the image was saved. + Might happen, especially on RasPi or other systems without an RTC" + lastCycleTime _ Time localMillisecondClock. + lastAlarmTime _ 0.! ! + +!WorldMorph methodsFor: 'initialization' stamp: 'jmv 10/21/2020 16:05:30'! +initialize + + super initialize. + activeHand _ HandMorph new. + hands _ { activeHand }. + damageRecorder _ DamageRecorder new. + stepList _ Heap sortBlock: self stepListSortBlock. + alarms _ Heap sortBlock: self alarmSortBlock. + lastAlarmTime _ 0. + deferredUIMessages _ SharedQueue new. + drawingFailingMorphs _ WeakIdentitySet new. + pause _ 20. + lastCycleTime _ Time localMillisecondClock. + lastCycleHadAnyEvent _ false! ! + +!WorldMorph methodsFor: 'initialization' stamp: 'jmv 2/2/2014 21:05'! +stepListSortBlock + + ^ [ :stepMsg1 :stepMsg2 | + stepMsg1 scheduledTime <= stepMsg2 scheduledTime ]! ! + +!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:16:15'! +cleanseStepList + "Remove morphs from the step list that are not in this World." + + | deletions | + deletions _ OrderedCollection new. + stepList do: [ :entry | + entry receiver world == self ifFalse: [ + deletions add: entry]]. + deletions do: [ :entry| + stepList remove: entry ]. + + deletions _ OrderedCollection new. + alarms do: [ :entry | + ((entry receiver is: #Morph) and: [ entry receiver world == self ]) ifFalse: [ + deletions add: entry]]. + deletions do: [ :entry| + alarms remove: entry ]! ! + +!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:35:50'! +runLocalStepMethods: nowTime + "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." + + | stepMessage | + [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] + whileTrue: [ + stepMessage _ stepList first. + (stepMessage receiver shouldGetStepsFrom: self) + ifFalse: [ stepList removeFirst ] + ifTrue: [ + stepMessage valueAtTime: nowTime. + stepMessage rescheduleAfter: nowTime. + "We've just updated the scheduled time for stepMessage. + It might have been that stepMessage was removed altogether from stepList. + It also may be the case that stepList got added or removed other elements while on #valueAtTime: + Just reSort. It will be ok in any case." + stepList reSort. + ] + ]! ! + +!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:34:17'! +runStepMethods + "Perform periodic activity inbetween event cycles" + | readyToProcess | + + "Processing the queue until empty is wrong if a block in it calls #addDeferredUIMessage: itself, because this loop will never end. + Instead, process no more than entries already in queue befor we start iterating!!" + readyToProcess _ deferredUIMessages size. + readyToProcess timesRepeat: [ + deferredUIMessages nextOrNil ifNotNil: [ :block | + block value + ] + ]. + self triggerAlarmsBefore: lastCycleTime. + self runLocalStepMethods: lastCycleTime. + + "we are using a normal #step for these now" + "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." +! ! + +!WorldMorph methodsFor: 'stepping' stamp: 'jmv 2/3/2014 21:15'! +startStepping: aMorph at: scheduledTime selector: aSelector stepTime: stepTimeOrNil + "Add the given morph to the step list" + + self stopStepping: aMorph selector: aSelector. + stepList add: ( + StepMessage + receiver: aMorph + selector: aSelector + at: scheduledTime + stepTime: stepTimeOrNil)! ! + +!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:34'! +stopStepping: aMorph selector: aSelector + "Remove the given morph from the step list." + stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and: [ stepMsg selector == aSelector ]])! ! + +!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:22'! +stopSteppingMorph: aMorph + "Remove the given morph from the step list." + stepList removeAll: (stepList select: [ :stepMsg | stepMsg receiver == aMorph])! ! + +!WorldMorph methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 13:13'! +checkIfUpdateNeeded + + damageRecorder updateIsNeeded ifTrue: [^true]. + hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]]. + ^false "display is already up-to-date" +! ! + +!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:16:56'! +displayWorldSafely + "Update this world's display and keep track of errors during draw methods." + + [self displayWorld] ifError: [:err :rcvr | + "Handle a drawing error" + | errCtx errMorph | + errCtx _ thisContext. + [ + errCtx _ errCtx sender. + "Search the sender chain to find the morph causing the problem" + [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] + whileTrue:[errCtx _ errCtx sender]. + "If we're at the root of the context chain then we have a fatal drawing problem" + errCtx ifNil:[^self handleFatalDrawingError: err]. + errMorph _ errCtx receiver. + "If the morph causing the problem has already the #drawError flag set, + then search for the next morph above in the caller chain." + errMorph isKnownFailing + ] whileTrue. + errMorph drawingFails. + self setCanvas. + "Install the old error handler, so we can re-raise the error" + rcvr error: err. + ]! ! + +!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:33:56'! +doOneCycle + "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. + + Make for low cpu usage if the ui is inactive, but quick response when ui is in use. + However, after some inactivity, there will be a larger delay before the ui gets responsive again." + + | wait waitUntil | + waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. + lastCycleHadAnyEvent | deferredUIMessages isEmpty not + ifTrue: [ + pause _ 20. "This value will only be used when there are no more events to serve." + wait _ 0 ] "Don't wait" + ifFalse: [ + pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." + ifTrue: [ pause _ pause * 21//20 ]. + waitUntil _ lastCycleTime + pause. + "Earlier if steps" + stepList isEmpty not ifTrue: [ + waitUntil _ waitUntil min: stepList first scheduledTime ]. + "Earlier if alarms" + alarms ifNotNil: [ + alarms isEmpty not ifTrue: [ + waitUntil _ waitUntil min: alarms first scheduledTime ]]. + + wait _ waitUntil - Time localMillisecondClock ]. + Preferences serverMode + ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." + wait > 0 + ifFalse: [ Processor yield ] + ifTrue: [ + waitDelay beingWaitedOn + ifFalse: [ waitDelay setDelay: wait; wait ] + ifTrue: [ + "If we are called from a different process than that of the main UI, we might be called in the main + interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" + (Delay forMilliseconds: wait) wait ]]. + + "Record start time of this cycle, and do cycle" + lastCycleTime _ Time localMillisecondClock. + lastCycleHadAnyEvent _ self doOneCycleNow! ! + +!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 16:04:46'! +doOneCycleNow + "Immediately do one cycle of the interaction loop. + Only used for a few tests." + "See #eventTickler" + | hadAnyEvent | + Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. + "Repair visual damage." + DisplayScreen checkForNewScreenSize. + self displayWorldSafely. + "Run steps, alarms and deferred UI messages" + self runStepMethods. + "Process user input events. Run all event triggered code." + hadAnyEvent _ false. + self handsDo: [ :h | + activeHand _ h. + hadAnyEvent _ hadAnyEvent | h processEventQueue. + activeHand _ nil ]. + "The default is the primary hand" + activeHand _ self hands first. + ^ hadAnyEvent.! ! + +!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 20:06:48'! +doOneMinimalCycleNow + "Immediately do one cycle of the interaction loop. + Only repair display and process events. For modal menus and such." + + "Repair visual damage." + self displayWorldSafely. + + "Process user input events. Run all event triggered code." + ^activeHand processEventQueue! ! + +!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 6/26/2015 14:36'! +handleFatalDrawingError: errMsg + "Handle a fatal drawing error." + + self primitiveError: + 'Fatal Morphic drawing error', String newLineString, + errMsg. + + "Hm... we should jump into a 'safe' WorldMorph here, but how do we find it?!!"! ! + +!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:17:28'! +tryDeferredUpdatingAndSetCanvas + "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." + | properDisplay | + + "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." + (Display deferUpdates: true) ifNil: [ + "deferred updates not supported by the VM, do them in the image!!" + self ensureNonDisplayCanvas. + ^ false]. + + "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" + properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. + properDisplay ifFalse: [ + self morphPosition: `0@0` extent: Display extent. + self setCanvas: Display getCanvas. + ]. + ^ true! ! + +!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:34:22'! +whenUIinSafeState: evaluableObject + "Please call + UISupervisor whenUIinSafeState: evaluableObject + " + deferredUIMessages nextPut: evaluableObject! ! + +!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59'! +addKnownFailing: aMorph + drawingFailingMorphs add: aMorph! ! + +!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59'! +isKnownFailing: aMorph + ^drawingFailingMorphs includes: aMorph! ! + +!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 10/21/2020 15:54:35'! +removeAllKnownFailing + drawingFailingMorphs _ WeakIdentitySet new. + self redrawNeeded! ! + +!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59'! +removeKnownFailing: aMorph + drawingFailingMorphs remove: aMorph! ! + +!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 17:06:37'! +displayWorld + "Update this world's display." + + | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | + self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" + "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." + deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. + + "repair world's damage on canvas" + worldDamageRects _ canvas drawWorld: self repair: damageRecorder. + + "Check which hands need to be drawn (they are not the hardware mouse pointer)" + handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. + allDamage _ Array streamContents: [ :strm | + strm nextPutAll: worldDamageRects. + handsToDraw do: [ :h | + h savePatchFrom: canvas appendDamageTo: strm ]]. + + "Draw hands (usually carying morphs) onto world canvas" + canvas newClipRect: nil. + handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. + + "quickly copy altered rects of canvas to Display:" + deferredUpdateVMMode ifFalse: [ + "Drawing was done to off-Display canvas. Copy content to Display" + canvas showAt: self viewBox origin invalidRects: allDamage ]. + + "Display deferUpdates: false." + "Display forceDisplayUpdate" + Display forceDamageToScreen: allDamage. + + "Restore world canvas under hands and their carried morphs" + handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! + +!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:41:02'! +drawOn: aCanvas + + "draw background image." + backgroundImage + ifNotNil: [ + aCanvas image: backgroundImage at: `0@0` ] + ifNil: [ + "draw background fill" + (aCanvas drawsOnDisplay and: [ color mightBeTranslucent ]) + ifTrue: [ + "Special case so a translucent background on the Display allows you to see through the main Cuis Window. + Requires proper handling of translucent Display in the VM. + Seems to work only on Linux when using a composing window manager." + (BitBlt toForm: Display) clipRect: aCanvas clipRect; + copy: Display boundingBox + from: `0@0` in: nil + fillColor: color rule: Form over. + Display forceToScreen] + ifFalse: [ super drawOn: aCanvas ]]! ! + +!WorldMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:04'! +wantsWindowEvent: anEvent + ^true! ! + +!WorldMorph methodsFor: 'classification' stamp: 'jmv 10/21/2020 15:47:06'! +isWorldMorph + + ^ true! ! + +!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:26:04'! +allMorphsDo: aBlock + "Enumerate all morphs in the world, including those held in hands." + + super allMorphsDo: aBlock. + self handsReverseDo: [:h | h allMorphsDo: aBlock].! ! + +!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:31:21'! +canHandle: aMorph + + ^ canvas canDraw: aMorph! ! + +!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 15:49:31'! +firstHand + + ^ hands first! ! + +!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/21/2020 15:50:52'! +invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph + "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." + + self recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph! ! + +!WorldMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:43:17'! +isReallyVisible + "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" + ^self visible! ! + +!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:39:39'! +displayBounds + ^0@0 extent: extent! ! + +!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:28'! +externalizeDisplayBounds: r + + ^ r! ! + +!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:55'! +externalizeToWorld: aPoint + "aPoint is in own coordinates. Answer is in world coordinates." + ^ aPoint! ! + +!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:42:23'! +internalizeFromWorld: aPoint + "aPoint is in World coordinates. Answer is in own coordinates." + ^ aPoint! ! + +!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:43:37'! +morphPositionInWorld + + self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" + ^ `0@0`! ! + +!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:52:21'! +privateExtent: newExtent + + ^ (super privateExtent: newExtent) + ifTrue: [ + self setCanvas ]; + yourself! ! + +!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:55:32'! +viewBox + + ^ self morphLocalBounds! ! + +!WorldMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 15:54:07'! +releaseCachedState + super releaseCachedState. + self cleanseStepList. + self clearCanvas! ! + +!WorldMorph methodsFor: 'structure' stamp: 'jmv 10/21/2020 15:56:00'! +world + ^self! ! + +!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:29:57'! +buildMagnifiedBackgroundImage + super buildMagnifiedBackgroundImage. + + canvas ifNotNil: [ :c | + (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ + backgroundImage _ backgroundImage orderedDither32To16 ]]! ! + +!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:52:25'! +fillRects: rectangleList + "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." + + + | blt screenRect | + blt _ (BitBlt toForm: Display) + sourceForm: nil; + sourceOrigin: `0@0`; + clipRect: self viewBox; + combinationRule: Form over. + + rectangleList do: [:r | + screenRect _ r translatedBy: self viewBox origin. + blt fillColor: Color random. + blt destRect: screenRect; copyBits. + Display forceToScreen: screenRect ]. + + (Delay forMilliseconds: 50) wait! ! + +!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:36:53'! +restoreDisplay + self + morphExtent: Display extent; + handsDo: [ :h | h visible: true ]; + fullRepaintNeeded! ! + +!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 10/21/2020 16:39:09'! +addCustomMenuItems: menu hand: aHandMorph + "Add morph-specific menu itemns to the menu for the hand" + + super addCustomMenuItems: menu hand: aHandMorph. + menu + add: 'desktop menu...' + target: self + action: #invokeWorldMenu. + menu addLine! ! + +!WorldMorph methodsFor: 'printing' stamp: 'jmv 10/21/2020 16:44:07'! +printOn: aStream + "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" + + aStream nextPutAll: ' [world]'! ! + +!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:19'! +deleteBalloonTarget: aMorph + "Delete the balloon help targeting the given morph" + self handsDo:[:h| h deleteBalloonTarget: aMorph].! ! + +!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:47:14'! +wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph + "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" + + ^#(addDebugHandle: addMenuHandle: addHelpHandle:) + statePointsTo: aSelector! ! + +!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:39'! +hideTaskbar + taskbar ifNotNil: [ + taskbar delete. + taskbar _ nil ]! ! + +!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:47'! +showTaskbar + + taskbar ifNil: [ + taskbar _ TaskbarMorph newRow. + taskbar openInWorld: self ]! ! + +!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:30'! +taskbar + ^taskbar! ! + +!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:01:03'! +taskbarDeleted + taskbar _ nil! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:04:22'! +collapseAll + "Collapse all windows" + (SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]) + reverseDo: [ :w | w collapse. self displayWorld]. + self collapseNonWindows! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:00:27'! +restoreAll + "Expand all windows to their previous state" + taskbar + ifNotNil: [ :tb | tb restoreAll ]! ! + +!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:07'! +recreateDefaultDesktop + | editor | + self whenUIinSafeState: [ + self hideTaskbar. + (submorphs + select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) + do: [ :ea | ea delete ]. + TranscriptWindow openTranscript + morphPosition: 5 @ 283; + morphExtent: 990 @ 400. + editor _ TextEditor openTextEditor + morphPosition: 456 @ 3; + morphExtent: 900 @ 680. + editor setLabel: 'About Cuis'. + editor model actualContents: Utilities defaultTextEditorContents. + Theme current useTaskbar ifTrue: [self showTaskbar]. + ].! ! + +!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:22'! +tearDownDesktop + self whenUIinSafeState: [ + self hideTaskbar. + submorphs + do: [ :ea | (ea is: #SystemWindow) ifTrue: [ ea delete ]]].! ! + +!WorldMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 17:11:53'! +click: aMouseButtonEvent localPosition: localEventPosition + ^self whenUIinSafeState: [self mouseButton2Activity]! ! + + +!WorldMorph class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 15:38:59'! +newWorld + " +[ + UISupervisor stopUIProcess. + UISupervisor spawnNewMorphicProcessFor: WorldMorph newWorld +] fork. + " + | w | + w _ self new. + w morphPosition: `0@0` extent: Display extent. + w setCanvas: Display getCanvas. + w handsDo: [ :h | + h privateOwner: w ]. + ^w! ! + +!WorldMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:42'! +initClassCachedState + "Should use some other way to find relevant instances" + self flag: #jmvVer2. + self allInstancesDo: [ :each | + each buildMagnifiedBackgroundImage. + each redrawNeeded ]. + Cursor defaultCursor activateCursor.! ! + + +!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 10/21/2020 17:02:09'! +preferencesMenu + "Build the preferences menu for the world." + + ^ (self menu: 'Preferences...') + addItemsFromDictionaries: { + { + #label -> 'Focus follows mouse'. + #object -> Preferences. + #selector -> #enableFocusFollowsMouse. + #icon -> #windowIcon. + #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' + } asDictionary. + { + #label -> 'Click to focus'. + #object -> Preferences. + #selector -> #disableFocusFollowsMouse. + #icon -> #windowIcon. + #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' + } asDictionary. + { + #label -> 'Font Sizes...'. + #object -> Theme. + #selector -> #changeFontSizes. + #icon -> #preferencesDesktopFontIcon. + #balloonText -> 'use larger or smaller text and widgets' + } asDictionary. + { + #label -> 'Set System Font...'. + #object -> FontFamily. + #selector -> #promptUserAndSetDefault. + #icon -> #preferencesDesktopFontIcon. + #balloonText -> 'change the current system font family.' + } asDictionary. + { + #label -> 'Load all TrueType Fonts'. + #object -> FontFamily. + #selector -> #readAdditionalTrueTypeFonts. + #icon -> #preferencesDesktopFontIcon. + #balloonText -> 'Load additional TrueType fonts included with Cuis.' + } asDictionary. + { + #label -> 'Icons...'. + #object -> Theme. + #selector -> #changeIcons. + #icon -> #worldIcon. + #balloonText -> 'show more or less icons.' + } asDictionary. + { + #label -> 'Themes...'. + #object -> Theme. + #selector -> #changeTheme. + #icon -> #appearanceIcon. + #balloonText -> 'switch to another theme.' + } asDictionary. + nil. + { + #label -> 'Show taskbar'. + #object -> #myWorld. + #selector -> #showTaskbar. + #icon -> #expandIcon. + #balloonText -> 'show the taskbar' + } asDictionary. + { + #label -> 'Hide taskbar'. + #object -> #myWorld. + #selector -> #hideTaskbar. + #icon -> #collapseIcon. + #balloonText -> 'hide the taskbar' + } asDictionary. + nil. + { + #label -> 'Full screen on'. + #selector -> #fullScreenOn. + #icon -> #viewFullscreenIcon. + #balloonText -> 'puts you in full-screen mode, if not already there.' + } asDictionary. + { + #label -> 'Full screen off'. + #selector -> #fullScreenOff. + #icon -> #exitFullscreenIcon. + #balloonText -> 'if in full-screen mode, takes you out of it.' + } asDictionary. + nil. + { + #label -> 'Set Code Author...'. + #object -> Utilities. + #selector -> #setAuthor. + #icon -> #usersIcon. + #balloonText -> 'supply initials to be used to identify the author of code and other content.' + } asDictionary. + { + #label -> 'All preferences...'. + #object -> Preferences. + #selector -> #openPreferencesInspector. + #icon -> #preferencesIcon. + #balloonText -> 'view and change various options.' + } asDictionary. + }! ! + +!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 10/21/2020 16:56:57'! +windowsMenu + "Build the windows menu for the world." + + ^ (self menu: 'Windows') + addItemsFromDictionaries: `{ + { + #label -> 'Find Window'. + #object -> #myWorld. + #selector -> #findWindow:. + #icon -> #windowIcon. + #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' + } asDictionary. + { + #label -> 'Find changed Browsers...'. + #object -> #myWorld. + #selector -> #findDirtyBrowsers:. + #icon -> #editFindReplaceIcon. + #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' + } asDictionary. + { + #label -> 'Find changed Windows...'. + #object -> #myWorld. + #selector -> #findDirtyWindows:. + #icon -> #newWindowIcon. + #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' + } asDictionary. + nil. + { + #label -> 'Find a Transcript'. + #object -> #myWorld. + #selector -> #findATranscript:. + #icon -> #printerIcon. + #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' + } asDictionary. + { + #label -> 'Find a FileList'. + #object -> #myWorld. + #selector -> #findAFileList:. + #icon -> #systemFileManagerIcon. + #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' + } asDictionary. + { + #label -> 'Find a Change Sorter'. + #object -> #myWorld. + #selector -> #findAChangeSorter:. + #icon -> #changesIcon. + #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' + } asDictionary. + { + #label -> 'Find Message Names'. + #object -> #myWorld. + #selector -> #findAMessageNamesWindow:. + #icon -> #inspectIcon. + #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' + } asDictionary. + nil. + { + #label -> 'Tile open windows'. + #object -> TileResizeMorph. + #selector -> #tileOpenWindows. + #icon -> #windowIcon. + #balloonText -> 'Tile open windows'. + } asDictionary. + { + #label -> 'Collapse all Windows'. + #object -> #myWorld. + #selector -> #collapseAll. + #icon -> #collapseIcon. + #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' + } asDictionary. + { + #label -> 'Restore all Windows'. + #object -> #myWorld. + #selector -> #restoreAll. + #icon -> #expandIcon. + #balloonText -> 'Restore all collapsed windows back to their previous forms.' + } asDictionary. + { + #label -> 'Close top Window'. + #object -> SystemWindow. + #selector -> #closeTopWindow. + #icon -> #closeIcon. + #balloonText -> 'Close the topmost window if possible.' + } asDictionary. + { + #label -> 'Send top Window to back'. + #object -> SystemWindow. + #selector -> #sendTopWindowToBack. + #icon -> #goBottomIcon. + #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' + } asDictionary. + { + #label -> 'Move Windows onscreen'. + #object -> #myWorld. + #selector -> #bringWindowsFullOnscreen. + #icon -> #displayIcon. + #balloonText -> 'Make all windows fully visible on the screen' + } asDictionary. + nil. + { + #label -> 'Delete unchanged Windows'. + #object -> #myWorld. + #selector -> #closeUnchangedWindows. + #icon -> #warningIcon. + #balloonText -> 'Deletes all windows that do not have unsaved text edits.' + } asDictionary. + { + #label -> 'Delete non Windows'. + #object -> #myWorld. + #selector -> #deleteNonWindows. + #icon -> #warningIcon. + #balloonText -> 'Deletes all non-window morphs lying on the world.' + } asDictionary. + { + #label -> 'Delete Both of the Above'. + #selector -> #cleanUpWorld. + #icon -> #warningIcon. + #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' + } asDictionary. + }`! ! + +"Postscript: +Leave the line above, and replace the rest of this comment by a useful one. +Executable statements should follow this comment, and should +be separated by periods, with no exclamation points (!!). +Be sure to put any further comments in double-quotes, like this one." +[ + | oldWorld ba roots w | + oldWorld _ UISupervisor ui. + ba _ oldWorld instVarNamed: 'backgroundImageData'. + roots _ oldWorld instVarNamed: 'submorphs'. + roots _ roots reject: [ :m | m is: #TaskbarMorph ]. + oldWorld _ nil. + UISupervisor stopUIProcess. + w _ WorldMorph newWorld. + w + "recreateDefaultDesktop;" + backgroundImageData: ba; + addAllMorphs: roots; + showTaskbar. + UISupervisor spawnNewMorphicProcessFor: w. + 'Please do [Install New Updates] again.' print. +] fork. +! + diff --git a/CoreUpdates/4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st b/CoreUpdates/4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st new file mode 100644 index 00000000..08669d0a --- /dev/null +++ b/CoreUpdates/4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st @@ -0,0 +1,264 @@ +'From Cuis 5.0 [latest update: #4417] on 21 October 2020 at 5:50:56 pm'! + +!Morph commentStamp: 'jmv 10/21/2020 17:46:54' prior: 0! +A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. + +Morphs exist in a tree, rooted at a World (a WorldMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets +drawn. To hide a Morph and its submorphs, send the #visible: message. + +Every morph has a local coordinate system to interpret positions. +Local coordinates are used in the #drawOn: method (the Canvas understands positions in the local coordinate system), for the positions of submorphs (for example #morphPosition and #morphPosition:) and for positions carried by mouse events. + +Events are delivered to morphs in Z-order, i.e. if a morph occludes another the event is only delivered to the foremost (just like physical objects). Events received by a morph carry positions in the local coordinate system. + +Morphs can be translated by an offset, rotated around their center, orbited (rotated around the owner center), and zoomed (i.e. scaled). + +Every morph has an associated transformation that defines the inner space where the morph is drawn and where the submorphs live. These transformations don't change anything from the internal point of view of the morph. + +Structure: +instance var Type Description +owner Morph or nil My parent Morph, or nil for the top-level Morph, which is a WorldMorph +submorphs Array My child Morphs. +location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner + See comment at GeometryTransformation! + + +!PasteUpMorph commentStamp: '' prior: 0! +My instances are free areas where you can play with Morphs. Most important, the World is an instance of my subclass WorldMorph.! + + +!WorldMorph commentStamp: '' prior: 0! +A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. + +activeHand -- a HandMorph +hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. +canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) +damageRecorder -- the DamageRecorder for the Display +stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. + See comment in #Morph>>stepAt: +lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) +lastStepMessage -- nil or a selector +lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) +alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: + An _alarm_ is an action to be done once, vs a _step_ which is cycled. +lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). +drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures +waitDelay -- a Delay +pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. +lastCycleHadAnyEvent -- a boolean +! + + +!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/21/2020 17:40:03'! +reduceCuis + " + Smalltalk reduceCuis + " + | keep n unused newDicts oldDicts | + + self nominallyUnsent: #reduceCuis. + + "Remove icons" + Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. + WorldMorph allInstancesDo: [ :w | + w backgroundImageData: nil. + w submorphsDo: [ :a | a delete ]]. + Preferences useNoMenuIcons. + Theme current initialize. + Theme content: nil. + Color shutDown. + BitBltCanvas releaseClassCachedState. + + Transcript clear. + Clipboard default initialize. + + + "Remove some methods, even if they have senders." + Utilities removeSelector: #vmStatisticsReportString. + SystemDictionary removeSelector: #recreateSpecialObjectsArray. + + StrikeFont saveSpace. + Smalltalk garbageCollect. + + Smalltalk removeEmptyMessageCategories. + Smalltalk organization removeEmptyCategories. + + keep := OrderedCollection new. + keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). + AppLauncher appGlobalName ifNotNil: [ :any | + keep add: any ]. + unused := Smalltalk unusedClasses copyWithoutAll: keep. + [ + #hereWeGo print. + unused do: [:c | + c print. + (Smalltalk at: c) removeFromSystem]. + n := Smalltalk removeAllUnSentMessages. + unused := Smalltalk unusedClasses copyWithoutAll: keep. + n > 0 or: [ + unused notEmpty ]] whileTrue. + ChangeSet zapAllChangeSets. + Smalltalk garbageCollect. + + Smalltalk removeEmptyMessageCategories. + Smalltalk organization removeEmptyCategories. + Symbol rehash. + + "Shrink method dictionaries." + Smalltalk garbageCollect. + oldDicts _ MethodDictionary allInstances. + newDicts _ Array new: oldDicts size. + oldDicts withIndexDo: [:d :index | + newDicts at: index put: d rehashWithoutBecome ]. + oldDicts elementsExchangeIdentityWith: newDicts. + oldDicts _ newDicts _ nil. + + SmalltalkCompleter initialize . + + "Sanity checks" +" Undeclared + Smalltalk cleanOutUndeclared + Smalltalk browseUndeclaredReferences + Smalltalk obsoleteClasses + Smalltalk obsoleteBehaviors + Smalltalk browseObsoleteMethodReferences + SmalltalkImage current fixObsoleteReferences + Smalltalk browseAllUnimplementedCalls"! ! + + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 17:47:25'! +fontPreferenceChanged + "Preferred fonts scale a number of window relations. + Let morphs which rely on this updte themselves. + + Note that the fontPreferenceChanged message is typically + sent to the current world. As WorldMorph inherits from me + the code below works fine for this." + + "I do nothing myself but my submorphs may." + + self submorphsDo: [ :m | m fontPreferenceChanged. ]! ! + +!Morph methodsFor: 'testing' stamp: 'jmv 10/21/2020 17:38:51'! +isOwnedByWorld + ^owner isWorldMorph! ! + + +!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 10/21/2020 17:49:39'! +world: aWorldMorph + world _ aWorldMorph. + self into: world! ! + +!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:48:51'! +computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage + "Iterate front to back while computing damage to actually repair for each morph, and for world background. + Answer uncoveredDamage, the areas where World background needs to be redrawn." + + | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance morphBefore | + morphDamage _ OrderedCollection new. + prevMorphDamage _ OrderedCollection new. + uncoveredDamage _ aDamageRecorder damageReportedOther. + "Iterate from front to back" + 1 to: rootMorphs size do: [ :i | + morph _ rootMorphs at: i. + morphDamage removeAll. + (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | + morphDamage add: r ]. + 1 to: i-1 do: [ :j | + reuseInstance _ prevMorphDamage. + prevMorphDamage _ morphDamage. + morphDamage _ reuseInstance removeAll. + morphBefore _ rootMorphs at: j. + prevMorphDamage do: [ :r | + morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. + (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | + rootMorphsDamage at: i put: morphDamageRect. + morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]. + + ^ uncoveredDamage! ! + +!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:48:42'! +drawWorld: aWorldMorph repair: aDamageRecorder + "Redraw the damaged areas and clear the damage list. + Return a collection of the areas that were redrawn. + Draw each morph just once, merging rectanges to be repaired as needed." + + | rootMorphs rootMorphsDamage worldDamage | + "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). + Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." + self updatingMorphBoundsDo: [ + aWorldMorph submorphsDo: [ :morph | + self fullAddRedrawRect: morph to: aDamageRecorder ]. + self updateHandsDisplayBounds: aWorldMorph ]. + + rootMorphs _ aWorldMorph privateSubmorphs. + rootMorphsDamage _ Array new: rootMorphs size. + + worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder + rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. + + self drawWorldBackground: aWorldMorph rects: worldDamage. + + self drawWorld: aWorldMorph + rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage + allDamage: worldDamage. + + aDamageRecorder reset. + ^ worldDamage! ! + +!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:49:10'! +drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage + "Redraw the damaged areas. + Draw each morph just once, merging rectanges to be repaired as needed." + + | morph morphDamage | + + "Iterate from back to front." + rootMorphs size to: 1 by: -1 do: [ :i | + morph _ rootMorphs at: i. + morph visible ifTrue: [ + morphDamage _ rootMorphsDamage at: i. + morph displayFullBounds ifNotNil: [ :morphFullBounds | + worldDamage do: [ :r | | intersection | + intersection _ r intersect: morphFullBounds. + intersection hasPositiveExtent ifTrue: [ + morphDamage _ intersection quickMerge: morphDamage ]]]. + morphDamage ifNotNil: [ + self newClipRect: morphDamage. + self fullDraw: morph. + worldDamage add: morphDamage ]]].! ! + +!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:49:27'! +drawWorldBackground: aWorldMorph rects: worldBackgroundDamage + "Draw worldBackgroundDamage rects for aWorldMorph. + Do not include submorphs." + + worldBackgroundDamage do: [ :r | + aWorldMorph drawOn: (self newClipRect: r) ].! ! + +!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:49:33'! +updateHandsDisplayBounds: aWorldMorph + "Update displayBounds for carried morphs if never set. + Useful for new morph, that are created and attached to the hand." + + aWorldMorph handsDo: [ :hand | + hand hasSubmorphs ifTrue: [ + self into: hand. + hand submorphsDo: [ :morph | + self updateDisplayBounds: morph ]. + self outOfMorph ]]! ! + + +!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 17:39:15'! +activeSubclass: aMorphicCanvasSubclass + ActiveSubclass _ aMorphicCanvasSubclass. + WorldMorph allInstancesDo: [ :w | w setCanvas ]! ! + +!methodRemoval: PasteUpMorph #is: stamp: 'jmv 10/21/2020 17:50:43'! +PasteUpMorph removeSelector: #is:! +!classRemoval: #OldPasteUpMorph stamp: 'jmv 10/21/2020 17:41:05'! +Smalltalk removeClassNamed: #OldPasteUpMorph! + +!classRemoval: #WorldState stamp: 'jmv 10/21/2020 17:41:11'! +Smalltalk removeClassNamed: #WorldState! + diff --git a/CoreUpdates/4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st b/CoreUpdates/4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st new file mode 100644 index 00000000..b22dbe59 --- /dev/null +++ b/CoreUpdates/4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st @@ -0,0 +1,455 @@ +'From Cuis 5.0 [latest update: #4418] on 22 October 2020 at 12:37:46 pm'! + +!WorldMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2020 12:31:25'! +handlesKeyboard + + ^ true ! ! + +!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/22/2020 12:23:07'! +addedMorph: aMorph + "Notify the receiver that the given morph was just added." + super addedMorph: aMorph. + self taskbar ifNotNil: [ :tb | + tb wasOpened: aMorph ]! ! + +!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/22/2020 12:33:24'! +removedMorph: aMorph + "Notify the receiver that aMorph was just removed from its children" + super removedMorph: aMorph. + self taskbar ifNotNil: [ :tb | + tb wasDeleted: aMorph ]! ! + +!WorldMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2020 12:25:35'! +allowsFilesDrop + + ^ true! ! + +!WorldMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2020 12:25:43'! +dropFiles: aDropFilesEvent + + (DropFilesAction for: aDropFilesEvent) value! ! + +!WorldMorph methodsFor: 'event handling' stamp: 'jmv 10/22/2020 12:20:47'! +mouseButton2Activity + + ^self invokeWorldMenu! ! + +!WorldMorph methodsFor: 'events' stamp: 'jmv 10/22/2020 12:32:01'! +keyStroke: aKeyboardEvent + "Handle a keystroke event." + (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) + ifTrue: [ + aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. + aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. + aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. + ]. + "aKeyboardEvent keyCharacter print." + ^ super keyStroke: aKeyboardEvent! ! + +!WorldMorph methodsFor: 'events' stamp: 'jmv 10/22/2020 12:35:57'! +windowEvent: aMorphicEvent + + aMorphicEvent windowEventType == #windowClose + ifTrue: [ + ^TheWorldMenu basicNew quitSession] +! ! + +!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 10/22/2020 12:32:35'! +mainLoop + + + self clearWaitDelay. + self setCanvas. + [ + self doOneCycle. + Processor yield. + true ] + whileTrue: []! ! + +!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 10/22/2020 12:37:28'! +runProcess + + | process | + + process _ [ self mainLoop ] newProcess. + process + priority: Processor userSchedulingPriority; + name: 'Morphic UI'; + animatedUI: self. + + ^ process! ! + +!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 10/22/2020 12:22:45'! +addWorldHaloMenuItemsTo: aMenu hand: aHandMorph + "Add standard halo items to the menu, given that the receiver is a World" + + | unlockables | + self addColorMenuItems: aMenu hand: aHandMorph. + +" aMenu addLine. + self addWorldToggleItemsToHaloMenu: aMenu." + aMenu addLine. + self addCopyItemsTo: aMenu. + self addExportMenuItems: aMenu hand: aHandMorph. + + self addDebuggingItemsTo: aMenu hand: aHandMorph. + + aMenu addLine. + aMenu defaultTarget: self. + + aMenu addLine. + + unlockables _ self submorphs select: + [ :m | m isLocked]. + unlockables size = 1 ifTrue: [ + aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. + unlockables size > 1 ifTrue: [ + aMenu add: 'unlock all contents' action: #unlockContents. + aMenu add: 'unlock...' action: #unlockOneSubpart]. + + aMenu defaultTarget: aHandMorph. +! ! + +!WorldMorph methodsFor: 'object serialization' stamp: 'jmv 10/22/2020 12:32:58'! +objectForDataStream: refStrm + "I am about to be written on an object file. Write a path to me in the other system instead." + + | dp | + dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). + refStrm replace: self with: dp. + ^ dp! ! + +!WorldMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 10/22/2020 12:22:24'! +addMorph: aMorph centeredNear: aPoint + "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." + + | trialRect delta | + trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. + delta _ trialRect amountToTranslateWithin: self displayBounds. + self addMorph: aMorph. + aMorph morphPositionInWorld: trialRect origin + delta.! ! + +!WorldMorph methodsFor: 'ui services' stamp: 'jmv 10/22/2020 12:34:19'! +request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock + "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." + ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! + +!WorldMorph methodsFor: 'ui services' stamp: 'jmv 10/22/2020 12:34:32'! +request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock + ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! + +!WorldMorph methodsFor: 'windows' stamp: 'jmv 10/22/2020 12:28:19'! +findATranscript + "Locate a transcript, open it, and bring it to the front. Create one if necessary" + + self + findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] + orMakeOneUsing: [ TranscriptWindow openTranscript ]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:26:09'! +bringWindowsFullOnscreen + "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." + (SystemWindow + windowsIn: self + satisfying: [ :w | + w visible ]) do: [ :each | + each makeMeFullyVisible ]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:26:30'! +closeUnchangedWindows + "Present a menu of window titles for all windows with changes, + and activate the one that gets chosen." + (SelectionMenu confirm: 'Do you really want to close all windows +except those with unaccepted edits?') ifFalse: [ ^ self ]. + (SystemWindow + windowsIn: self + satisfying: [ :w | + w visible and: [ w canDiscardEdits ]]) do: [ :w | + w delete ]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:23:43'! +collapseNonWindows + self allNonWindowRelatedSubmorphs do: [ :m | + m collapse]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:23:50'! +deleteNonWindows + (SelectionMenu confirm: +'Do you really want to discard all objects +that are not in windows?') + ifFalse: [^ self]. + + self allNonWindowRelatedSubmorphs do: [:m | + m delete ]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:27:41'! +findAChangeSorter: evt + "Locate a change sorter, open it, and bring it to the front. Create one if necessary" + self + findAWindowSatisfying: [ :aWindow | + aWindow model isMemberOf: ChangeSorter] + orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:27:48'! +findAFileList: evt + "Locate a file list, open it, and bring it to the front. + Create one if necessary, respecting the Preference." + self + findAWindowSatisfying: [ :aWindow | + aWindow model class == FileList ] + orMakeOneUsing: [ + FileListWindow openFileList ]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:27:57'! +findAMessageNamesWindow: evt + "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" + self + findAWindowSatisfying: [ :aWindow | + aWindow model class == MessageNames ] + orMakeOneUsing: [ + MessageNamesWindow open: MessageNames new label: 'Message Names' ]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:13'! +findATranscript: evt + "Locate a transcript, open it, and bring it to the front. Create one if necessary" + + self findATranscript! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:35'! +findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock + "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" + | aWindow | + submorphs do: [ :aMorph | + (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ + aWindow isCollapsed ifTrue: [ aWindow expand ]. + aWindow activateAndForceLabelToShow. + ^ self ]]. + "None found, so create one" + makeBlock value.! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:49'! +findDirtyBrowsers: evt + "Present a menu of window titles for browsers with changes, + and activate the one that gets chosen." + | menu | + menu _ MenuMorph new. + (SystemWindow + windowsIn: self + satisfying: [ :w | + w visible and: [ + (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | + menu + add: w label + target: w + action: #activate ]. + menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:59'! +findDirtyWindows: evt + "Present a menu of window titles for all windows with changes, + and activate the one that gets chosen." + | menu | + menu _ MenuMorph new. + (SystemWindow + windowsIn: self + satisfying: [ :w | + w visible and: [ w canDiscardEdits not ]]) do: [ :w | + menu + add: w label + target: w + action: #activate ]. + menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:29:06'! +findWindow: evt + "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." + | menu expanded collapsed nakedMorphs | + menu _ MenuMorph new. + expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. + collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. + nakedMorphs _ self submorphsSatisfying: [ :m | + (m is: #SystemWindow) not ]. + expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. + (expanded asArray sort: [ :w1 :w2 | + w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | + menu + add: w label + target: w + action: #activateAndForceLabelToShow. + w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. + expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. + (collapsed asArray sort: [ :w1 :w2 | + w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | + menu + add: w label + target: w + action: #expand. + w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. + nakedMorphs isEmpty ifFalse: [ menu addLine ]. + (nakedMorphs asArray sort: [ :w1 :w2 | + w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | + menu + add: w label + target: w + action: #comeToFrontAndAddHalo ]. + menu addTitle: 'find window'. + menu popUpInWorld: self! ! + +!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:20:57'! +invokeWorldMenu + "Put up the world menu, triggered by the passed-in event. + Perhaps a good place to disable it if needed" + + | menu | + menu _ (TheWorldMenu new + world: self + hand: self activeHand) buildWorldMenu. + menu addTitle: Preferences desktopMenuTitle. + menu popUpInWorld: self! ! + +!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:24:00'! +allNonWindowRelatedSubmorphs + "Answer all non-window submorphs that are not flap-related" + + ^submorphs + reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! + +!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:27:17'! +deleteAllHalos + self haloMorphs do: + [ :m | m delete]! ! + +!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:30:43'! +fullRepaintNeeded + self redrawNeeded. + SystemWindow + windowsIn: self + satisfying: [ :w | + w visible ifTrue: [ w makeMeVisible ]. + false ]! ! + +!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:27:23'! +haloMorphs + ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! ! + +!methodRemoval: PasteUpMorph #findWindow: stamp: 'jmv 10/22/2020 12:29:06'! +PasteUpMorph removeSelector: #findWindow:! +!methodRemoval: PasteUpMorph #closeUnchangedWindows stamp: 'jmv 10/22/2020 12:26:30'! +PasteUpMorph removeSelector: #closeUnchangedWindows! +!methodRemoval: PasteUpMorph #findATranscript: stamp: 'jmv 10/22/2020 12:28:13'! +PasteUpMorph removeSelector: #findATranscript:! +!methodRemoval: PasteUpMorph #keyStroke: stamp: 'jmv 10/22/2020 12:32:01'! +PasteUpMorph removeSelector: #keyStroke:! +!methodRemoval: PasteUpMorph #addedMorph: stamp: 'jmv 10/22/2020 12:23:07'! +PasteUpMorph removeSelector: #addedMorph:! +!methodRemoval: PasteUpMorph #mouseButton2Activity stamp: 'jmv 10/22/2020 12:20:47'! +PasteUpMorph removeSelector: #mouseButton2Activity! +!methodRemoval: PasteUpMorph #findATranscript stamp: 'jmv 10/22/2020 12:28:19'! +PasteUpMorph removeSelector: #findATranscript! +!methodRemoval: PasteUpMorph #fullRepaintNeeded stamp: 'jmv 10/22/2020 12:30:43'! +PasteUpMorph removeSelector: #fullRepaintNeeded! +!methodRemoval: PasteUpMorph #request:initialAnswer:orCancel: stamp: 'jmv 10/22/2020 12:34:19'! +PasteUpMorph removeSelector: #request:initialAnswer:orCancel:! +!methodRemoval: PasteUpMorph #windowEvent: stamp: 'jmv 10/22/2020 12:35:57'! +PasteUpMorph removeSelector: #windowEvent:! +!methodRemoval: PasteUpMorph #deleteAllHalos stamp: 'jmv 10/22/2020 12:27:17'! +PasteUpMorph removeSelector: #deleteAllHalos! +!methodRemoval: PasteUpMorph #request:initialAnswer:verifying:do:orCancel: stamp: 'jmv 10/22/2020 12:34:32'! +PasteUpMorph removeSelector: #request:initialAnswer:verifying:do:orCancel:! +!methodRemoval: PasteUpMorph #findDirtyWindows: stamp: 'jmv 10/22/2020 12:28:59'! +PasteUpMorph removeSelector: #findDirtyWindows:! +!methodRemoval: PasteUpMorph #mainLoop stamp: 'jmv 10/22/2020 12:32:35'! +PasteUpMorph removeSelector: #mainLoop! +!methodRemoval: PasteUpMorph #dropFiles: stamp: 'jmv 10/22/2020 12:25:43'! +PasteUpMorph removeSelector: #dropFiles:! +!methodRemoval: PasteUpMorph #handlesKeyboard stamp: 'jmv 10/22/2020 12:31:25'! +PasteUpMorph removeSelector: #handlesKeyboard! +!methodRemoval: PasteUpMorph #findAMessageNamesWindow: stamp: 'jmv 10/22/2020 12:27:57'! +PasteUpMorph removeSelector: #findAMessageNamesWindow:! +!methodRemoval: PasteUpMorph #collapseNonWindows stamp: 'jmv 10/22/2020 12:23:43'! +PasteUpMorph removeSelector: #collapseNonWindows! +!methodRemoval: PasteUpMorph #findAChangeSorter: stamp: 'jmv 10/22/2020 12:27:41'! +PasteUpMorph removeSelector: #findAChangeSorter:! +!methodRemoval: PasteUpMorph #findAWindowSatisfying:orMakeOneUsing: stamp: 'jmv 10/22/2020 12:28:35'! +PasteUpMorph removeSelector: #findAWindowSatisfying:orMakeOneUsing:! +!methodRemoval: PasteUpMorph #findAFileList: stamp: 'jmv 10/22/2020 12:27:48'! +PasteUpMorph removeSelector: #findAFileList:! +!methodRemoval: PasteUpMorph #findDirtyBrowsers: stamp: 'jmv 10/22/2020 12:28:49'! +PasteUpMorph removeSelector: #findDirtyBrowsers:! +!methodRemoval: PasteUpMorph #activeHand stamp: 'jmv 10/22/2020 12:20:12'! +PasteUpMorph removeSelector: #activeHand! +!methodRemoval: PasteUpMorph #haloMorphs stamp: 'jmv 10/22/2020 12:27:23'! +PasteUpMorph removeSelector: #haloMorphs! +!methodRemoval: PasteUpMorph #deleteNonWindows stamp: 'jmv 10/22/2020 12:23:50'! +PasteUpMorph removeSelector: #deleteNonWindows! +!methodRemoval: PasteUpMorph #invokeWorldMenu stamp: 'jmv 10/22/2020 12:20:57'! +PasteUpMorph removeSelector: #invokeWorldMenu! +!methodRemoval: PasteUpMorph #addMorph:centeredNear: stamp: 'jmv 10/22/2020 12:22:24'! +PasteUpMorph removeSelector: #addMorph:centeredNear:! +!methodRemoval: PasteUpMorph #objectForDataStream: stamp: 'jmv 10/22/2020 12:32:58'! +PasteUpMorph removeSelector: #objectForDataStream:! +!methodRemoval: PasteUpMorph #runProcess stamp: 'jmv 10/22/2020 12:37:28'! +PasteUpMorph removeSelector: #runProcess! +!methodRemoval: PasteUpMorph #bringWindowsFullOnscreen stamp: 'jmv 10/22/2020 12:26:09'! +PasteUpMorph removeSelector: #bringWindowsFullOnscreen! +!methodRemoval: PasteUpMorph #allowsFilesDrop stamp: 'jmv 10/22/2020 12:25:35'! +PasteUpMorph removeSelector: #allowsFilesDrop! +!methodRemoval: PasteUpMorph #allNonWindowRelatedSubmorphs stamp: 'jmv 10/22/2020 12:24:00'! +PasteUpMorph removeSelector: #allNonWindowRelatedSubmorphs! +!methodRemoval: PasteUpMorph #addWorldHaloMenuItemsTo:hand: stamp: 'jmv 10/22/2020 12:22:45'! +PasteUpMorph removeSelector: #addWorldHaloMenuItemsTo:hand:! +!methodRemoval: PasteUpMorph #removedMorph: stamp: 'jmv 10/22/2020 12:33:24'! +PasteUpMorph removeSelector: #removedMorph:! + +!PasteUpMorph reorganize! +('accessing' color:) +('caching' releaseCachedState) +('drawing' drawOn:) +('dropping/grabbing' allowsMorphDrop allowsSubmorphDrag) +('events' mouseButton1Down:localPosition:) +('event handling testing' handlesMouseDown:) +('event handling' wantsWindowEvent:) +('geometry' fontPreferenceChanged privateExtent:) +('initialization' defaultBorderColor defaultBorderWidth defaultColor) +('misc' backgroundImage backgroundImageData: buildMagnifiedBackgroundImage) +('stepping and presenter' wantsSteps) +('testing' isReallyVisible) +('halos and balloon help' wantsHaloHandleWithSelector:inHalo:) +! + + +!WorldMorph reorganize! +('accessing' handlesKeyboard) +('alarms' addAlarm:withArguments:for:at: adjustAlarmTimes: alarmSortBlock removeAlarm:for: triggerAlarmsBefore:) +('caching' releaseCachedState) +('canvas' canvas clearCanvas ensureNonDisplayCanvas recordDamagedRect:for: setCanvas setCanvas:) +('change reporting' addedMorph: invalidateDisplayRect:fromSubmorph:for: removedMorph:) +('classification' isWorldMorph) +('defaul desktop' recreateDefaultDesktop tearDownDesktop) +('drawing' displayWorld drawOn:) +('dropping/grabbing' allowsFilesDrop dropFiles:) +('errors on draw' addKnownFailing: isKnownFailing: removeAllKnownFailing removeKnownFailing:) +('event handling' mouseButton2Activity wantsWindowEvent:) +('events' click:localPosition: keyStroke: windowEvent:) +('geometry' displayBounds externalizeDisplayBounds: externalizeToWorld: internalizeFromWorld: morphPositionInWorld privateExtent: viewBox) +('halos and balloon help' deleteBalloonTarget: wantsHaloHandleWithSelector:inHalo:) +('hands' activeHand hands handsDo: handsReverseDo: selectHandsToDrawForDamage:) +('initialization' clearWaitDelay initialize stepListSortBlock) +('interaction loop' mainLoop runProcess) +('menu & halo' addCustomMenuItems:hand: addWorldHaloMenuItemsTo:hand:) +('misc' buildMagnifiedBackgroundImage fillRects: restoreDisplay) +('object serialization' objectForDataStream:) +('printing' printOn:) +('stepping' cleanseStepList runLocalStepMethods: runStepMethods startStepping:at:selector:stepTime: stopStepping:selector: stopSteppingMorph:) +('structure' world) +('submorphs-accessing' allMorphsDo: canHandle: firstHand) +('submorphs-add/remove' addMorph:centeredNear:) +('taskbar' hideTaskbar showTaskbar taskbar taskbarDeleted) +('testing' isReallyVisible) +('ui services' request:initialAnswer:orCancel: request:initialAnswer:verifying:do:orCancel:) +('update cycle' checkIfUpdateNeeded displayWorldSafely doOneCycle doOneCycleNow doOneMinimalCycleNow handleFatalDrawingError: tryDeferredUpdatingAndSetCanvas whenUIinSafeState:) +('windows' findATranscript) +('world menu' bringWindowsFullOnscreen closeUnchangedWindows collapseAll collapseNonWindows deleteNonWindows findAChangeSorter: findAFileList: findAMessageNamesWindow: findATranscript: findAWindowSatisfying:orMakeOneUsing: findDirtyBrowsers: findDirtyWindows: findWindow: invokeWorldMenu restoreAll) +('world state' allNonWindowRelatedSubmorphs deleteAllHalos fullRepaintNeeded haloMorphs) +! + diff --git a/CoreUpdates/4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st b/CoreUpdates/4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st new file mode 100644 index 00000000..8f51e6aa --- /dev/null +++ b/CoreUpdates/4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st @@ -0,0 +1,19 @@ +'From Cuis 5.0 [latest update: #4422] on 23 October 2020 at 8:32:07 pm'! +!classDefinition: #MovableMorph category: #'Morphic-Kernel'! +Morph subclass: #MovableMorph + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Kernel'! +!classDefinition: #KernelMorph category: #'Morphic-Kernel'! +MovableMorph subclass: #KernelMorph + instanceVariableNames: 'extent color' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Kernel'! +!classDefinition: #WidgetMorph category: 'Morphic-Widgets'! +MovableMorph subclass: #WidgetMorph + instanceVariableNames: 'extent color borderWidth borderColor' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Widgets'! diff --git a/CoreUpdates/4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st b/CoreUpdates/4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st new file mode 100644 index 00000000..708b8b6e --- /dev/null +++ b/CoreUpdates/4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st @@ -0,0 +1,630 @@ +'From Cuis 5.0 [latest update: #4423] on 23 October 2020 at 11:01:16 pm'! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:52:00'! +scale + ^1! ! + + +!MovableMorph methodsFor: 'accessing' stamp: 'jmv 10/23/2020 20:34:55'! +location + ^location! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:51:57'! +allocHeightForFactor: aFactor + + "Morphs with LayoutSpecs may specify propottional layouts and minimum extents + amountToAlloc * proportion * factor >= minHeight + so breakeven is when + amountToAlloc = minHeight / proportion * factor" + | minHeight | + minHeight := self minimumLayoutHeight. + ^(self isProportionalHeight) + ifFalse: [ minHeight ] + ifTrue: [ minHeight / (aFactor * self layoutSpec privateProportionalHeight) ]! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:52:01'! +allocWidthForFactor: aFactor + + "Morphs with LayoutSpecs may specify propottional layouts and minimum extents + amountToAlloc * proportion * factor >= minWidth + so breakeven is when + amountToAlloc = minWidth / proportion * factor" + | minWidth | + minWidth := self minimumLayoutWidth. + ^(self isProportionalWidth) + ifFalse: [ minWidth ] + ifTrue: [ minWidth / (aFactor * self layoutSpec privateProportionalWidth) ]! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:35:29'! +externalize: aPoint + "aPoint is in own coordinates. Answer is in owner's coordinates." + "Must include scale and rotation!!" + self flag: #jmvVer2. + ^ location externalizePosition: aPoint! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:02'! +externalizeDisplayBounds: r + + | inOwners | + "All senders of #displayBoundsOfTransformOf: should be rethought..." + self flag: #jmvVer2. + + inOwners _ location displayBoundsOfTransformOf: r. + ^owner + ifNotNil: [ owner externalizeDisplayBounds: inOwners ] + ifNil: [ inOwners ]! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:07'! +externalizeDistance: aPoint + "aPoint is in own coordinates. Answer is in owner's coordinates." + ^ location externalizeDelta: aPoint! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:17'! +internalize: aPoint + "aPoint is in owner's coordinates. Answer is in own coordinates." + ^ location internalizePosition: aPoint! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:22'! +internalizeDistance: aPoint + "aPoint is in owner's coordinates. Answer is in own coordinates." + ^ location internalizeDelta: aPoint! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:38:46'! +minimumLayoutExtent + "This returns the minimum extent that the morph may be shrunk to, + when resizing LayoutMorphs. + It is expressed in the morph own coordinates, like morphExtent." + + "This method combines the information from a Morph and its optional LayoutSpec" + | minExtent | + minExtent _ self minimumExtent. + ^ layoutSpec + ifNil: [ minExtent ] + ifNotNil: [ minExtent max: ( layoutSpec minimumSpecWidth @ layoutSpec minimumSpecHeight ) ]! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:59:39'! +morphAlign: aPoint with: anotherPoint + ^ self morphPosition: self morphPosition + anotherPoint - aPoint! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:27'! +morphPosition + "Answer our position inside our owner, in owner's coordinates." + + ^ location translation! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:47'! +morphPosition: aPoint + "Change the position of this morph. Argument is in owner's coordinates." + (location isTranslation: aPoint) ifTrue: [ "Null change" + ^ self ]. + location _ location withTranslation: aPoint. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. + self redrawNeeded.! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:52'! +morphPositionInWorld: newPositionInWorld + "Change the position of this morph." + "El tema es, que tipo de coordenadas tenemos? + En un mundo relativista, no hay un marco de referencia absoluto. + No tiene sentido hablar de coordenadas del mundo... El mundo podria estar escalado... + Que tienen de especial las coordenadas del mundo? + Coordenadas 'del hardware'? No deberia saber mucho sobre el... Puede haber multiples displays, hands de diverso tipo, remotas, virtuales... + + En ppio, un par de coordenadas pueden ser relativas a cualquier morph. Pareciera que necesito metodos de conversion de cualquier morph hacia mi, y de mi hacia cualquier morph... Como encontrar un marco de referencia comun???? + Dejar esto para despues. En realidad, para empezar, preciso menos: Solo preciso saber si las coordenadas estan en el morph o en su owner. Nada mas. Los eventos se iran transformando apropiadamente al moverse por el arbol, o al menos, llevaran consigo una transformacion (AffineTransformation) que se ira actualizando" + + | newPositionInOwner | + self flag: #jmvVer2. + "This method MUST die" + + newPositionInOwner _ owner + ifNotNil: [ owner internalizeFromWorld: newPositionInWorld ] + ifNil: [ newPositionInWorld ]. + + (location isTranslation: newPositionInOwner) ifTrue: [ + ^ self ]. "Null change". + + location _ location withTranslation: newPositionInOwner. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. + self redrawNeeded.! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:56'! +orbitBy: radians + "Change the scale of this morph. Arguments are an angle and a scale." + location _ (AffineTransformation withRadians: radians) composedWith: location. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. + self redrawNeeded.! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:12:43'! +referencePosition + "Return the current reference position of the receiver" + "a rather ugly way to say #center . At least, we avoid false polymorphism" + "remove some day" + self flag: #jmvVer2. + ^self morphExtentInWorld // 2 + self morphPositionInWorld! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:12:37'! +referencePosition: aPoint + "a rather ugly way to say #center: . Just for consistency with #referencePosition" + "remove some day" + self flag: #jmvVer2. + self morphPositionInWorld: aPoint - (self morphExtentInWorld // 2)! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:37:10'! +rotateBy: radians + "Change the rotation of this morph. Argument is an angle (possibly negative), to be added to current rotation." + + location _ location rotatedBy: radians. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. + self redrawNeeded.! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:39'! +rotation: radians + "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." + + self rotation: radians scale: location scale.! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:37:14'! +rotation: radians scale: scale + "Change the rotation and scale of this morph. Arguments are an angle and a scale." + location _ location withRotation: radians scale: scale. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. + self redrawNeeded.! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:49:21'! +rotationDegrees: degrees + location _ location rotatedBy: degrees degreesToRadians - location radians. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. + self redrawNeeded.! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:51:47'! +scale + ^location scale! ! + +!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:37:22'! +scaleBy: scaleFactor + "Change the scale of this morph. Argument is a factor." + location _ location scaledBy: scaleFactor. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. + self redrawNeeded.! ! + +!MovableMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 20:38:03'! +initialize + "initialize the state of the receiver" + + super initialize. + location _ MorphicTranslation new.! ! + +!MovableMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 21:41:33'! +openInWorld: aWorld + "Add this morph to the requested World." + location isIdentity + ifTrue: [ aWorld addMorph: self position: `50@50` ] + ifFalse: [ aWorld addMorph: self ]! ! + +!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:54:32'! +minimumLayoutHeight + "I combine information from a Morph and its optional LayoutSpec" + | minHeight | + + minHeight _ self minimumExtent y. "from morph (me)." + ^ layoutSpec + ifNil: [ minHeight ] + ifNotNil: [ :ls | minHeight max: (ls minimumSpecHeight )] +! ! + +!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:54:35'! +minimumLayoutWidth + "I combine information from a Morph and its optional LayoutSpec" + | minWidth | + + minWidth _ self minimumExtent x. "from morph (me)." + ^ layoutSpec + ifNil: [ minWidth ] + ifNotNil: [ :ls | minWidth max: (ls minimumSpecWidth )] +! ! + +!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 20:38:51'! +minimumShrinkExtent + "This returns the minimum extent that the morph may be shrunk to. + It is expressed in the morph own coordinates, like morphExtent." + + | minExtent | + minExtent _ self minimumExtent. + ^ layoutSpec + ifNil: [ minExtent ] + ifNotNil: [ minExtent max: layoutSpec minimumShrinkWidth @ layoutSpec minimumShrinkHeight ]! ! + +!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 20:38:57'! +minimumShrinkHeight + "This returns the minimum height that the morph may be shrunk to by a LayoutAdjustingMorph. + It is expressed in the morph own coordinates, like morphExtent." + + | minShrinkHeight | + minShrinkHeight _ self minimumExtent y. + ^ layoutSpec + ifNil: [ minShrinkHeight ] + ifNotNil: [ minShrinkHeight max: layoutSpec minimumShrinkHeight ]! ! + +!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 20:39:01'! +minimumShrinkWidth + "This returns the minimum width that the morph may be shrunk to by a LayoutAdjustingMorph. + It is expressed in the morph own coordinates, like morphExtent." + + | minShrinkWidth | + minShrinkWidth _ self minimumExtent x. + ^ layoutSpec + ifNil: [ minShrinkWidth ] + ifNotNil: [ minShrinkWidth max: layoutSpec minimumShrinkWidth ]! ! + +!MovableMorph methodsFor: 'private' stamp: 'jmv 10/23/2020 20:37:02'! +privateOwner: aMorph + "Private!! Should only be used by methods that maintain the ower/submorph invariant." + + | oldGlobalPosition prevOwner | + + self flag: #jmvVer2. + "Is this the best behavior???" + prevOwner _ owner. + prevOwner + ifNotNil: [ + "Had an owner. Maintain my global position..." + oldGlobalPosition _ self morphPositionInWorld ]. + owner _ aMorph. + owner + ifNil: [ + "Won't have any owner. Keep local position, as it will be maintained in my new owner later" + ] + ifNotNil: [ + prevOwner + ifNil: [ + "Didn't have any owner. Assume my local position is to be maintained in my new owner" + ] + ifNotNil: [ + "Had an owner. Maintain my global position..." + location _ location withTranslation: (owner internalizeFromWorld: oldGlobalPosition). + self flag: #jmvVer2. + "extent _ owner internalizeDistanceFromWorld: oldGlobalExtent" "or something like this!!" + ]]! ! + +!MovableMorph methodsFor: 'private' stamp: 'jmv 10/23/2020 20:37:06'! +privatePosition: aPoint + "Change the position of this morph. Argument is in owner's coordinates." + + (location isTranslation: aPoint) ifTrue: [ + ^ self ]. "Null change" + + location _ location withTranslation: aPoint! ! + +!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 10/23/2020 20:39:08'! +layoutSpec + "Layout specific. Return the layout spec describing where the + receiver should appear in a proportional layout" + + layoutSpec ifNotNil: [ :ls | ^ ls ]. + layoutSpec := LayoutSpec keepMorphExtent. + layoutSpec morph: self. + + ^ layoutSpec ! ! + +!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 10/23/2020 20:39:14'! +layoutSpec: aLayoutSpec + "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" + aLayoutSpec + useMorphWidth; + useMorphHeight. + self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. + aLayoutSpec morph: self. + layoutSpec := aLayoutSpec. + owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! ! + +!MovableMorph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:54:25'! +isProportionalHeight + "Answer true if I have a layoutSpec which specifies a proportional layout" + + ^ layoutSpec + ifNil: [ false ] + ifNotNil: [ :ls | ls isProportionalHeight ]! ! + +!MovableMorph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:54:29'! +isProportionalWidth + "Answer true if I have a layoutSpec which specifies a proportional layout" + + ^ layoutSpec + ifNil: [ false ] + ifNotNil: [ :ls | ls isProportionalWidth ]! ! + + +!Morph methodsFor: 'accessing' stamp: 'jmv 10/23/2020 21:16:48'! +location + ^nil! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:18:12'! +externalize: aPoint + "aPoint is in own coordinates. Answer is in owner's coordinates." + "Must include scale and rotation!!" + ^ aPoint! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:20:39'! +externalizeDisplayBounds: r + + "All senders of #displayBoundsOfTransformOf: should be rethought..." + self flag: #jmvVer2. + + ^owner + ifNotNil: [ owner externalizeDisplayBounds: r ] + ifNil: [ r encompassingIntegerRectangle ]! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:22:26'! +externalizeDistance: aPoint + "aPoint is in own coordinates. Answer is in owner's coordinates." + ^ aPoint! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:22:46'! +internalize: aPoint + "aPoint is in owner's coordinates. Answer is in own coordinates." + ^ aPoint! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:23:01'! +internalizeDistance: aPoint + "aPoint is in owner's coordinates. Answer is in own coordinates." + ^ aPoint! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:21:42'! +morphExtentInWorld + "eventually, remove." + self flag: #jmvVer2. + ^(self externalizeDistanceToWorld: self morphExtent) ceiling! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:00:55'! +morphPosition + "Answer our position inside our owner, in owner's coordinates." + self flag: #jmvVer2. self revisar. "useless" + ^ 0@0! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:59:44'! +morphPosition: aPoint + "Change the position of this morph. Argument is in owner's coordinates. + Ignored by morphs that are not resizeable"! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 23:00:38'! +morphPositionInWorld: newPositionInWorld + "Change the position of this morph. Argument is in world coordinates. + Ignored by morphs that are not movable"! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:15:39'! +referencePosition + "Return the current reference position of the receiver" + "a rather ugly way to say #center . At least, we avoid false polymorphism" + "remove some day" + self flag: #jmvVer2. self revisar. "useless" + ^0@0! ! + +!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:04:37'! +rotation: radians scale: scale + "Change the rotation and scale of this morph. Arguments are an angle and a scale. + Ignored by us. Redefined in some subclasses." + self flag: #jmvVer2. self revisar. "useless?"! ! + +!Morph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 20:38:06'! +initialize + "initialize the state of the receiver" + + owner _ nil. + submorphs _ #(). + id _ 0.! ! + +!Morph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 21:41:47'! +openInWorld: aWorld + "Add this morph to the requested World." + aWorld addMorph: self! ! + +!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:28:05'! +minimumLayoutHeight + "I combine information from a Morph and its optional LayoutSpec" + + ^self minimumExtent y.! ! + +!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:27:56'! +minimumLayoutWidth + "I combine information from a Morph and its optional LayoutSpec" + + ^self minimumExtent x.! ! + +!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:46:12'! +minimumShrinkExtent + "This returns the minimum extent that the morph may be shrunk to. + It is expressed in the morph own coordinates, like morphExtent." + + ^ self minimumExtent.! ! + +!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:46:40'! +minimumShrinkHeight + "This returns the minimum height that the morph may be shrunk to by a LayoutAdjustingMorph. + It is expressed in the morph own coordinates, like morphExtent." + + ^ self minimumExtent y.! ! + +!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:46:53'! +minimumShrinkWidth + "This returns the minimum width that the morph may be shrunk to by a LayoutAdjustingMorph. + It is expressed in the morph own coordinates, like morphExtent." + + ^ self minimumExtent x.! ! + +!Morph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:26:45'! +isProportionalHeight + "Answer true if I have a layoutSpec which specifies a proportional layout" + + ^false! ! + +!Morph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:49:21'! +isProportionalWidth + "Answer true if I have a layoutSpec which specifies a proportional layout" + + ^ false! ! + +!Morph methodsFor: 'private' stamp: 'jmv 10/23/2020 21:48:13'! +privateOwner: aMorph + "Private!! Should only be used by methods that maintain the ower/submorph invariant." + + owner _ aMorph.! ! + +!Morph methodsFor: 'private' stamp: 'jmv 10/23/2020 23:00:44'! +privatePosition: aPoint + "Change the position of this morph. Argument is in owner's coordinates. + Ignored by morphs that are not movable"! ! + + +!HaloMorph methodsFor: 'private' stamp: 'jmv 10/23/2020 20:52:06'! +startRot: evt with: rotHandle + "Initialize rotation of my target if it is rotatable. Launch a command object to represent the action" + + evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" + growingOrRotating _ true. + + self removeAllHandlesBut: rotHandle. "remove all other handles" + angleOffset _ evt eventPosition - target referencePosition. + angleOffset _ Point + r: angleOffset r + degrees: angleOffset degrees - target rotationDegrees. + scaleOffset _ target scale / (evt eventPosition - target referencePosition) rho. + +! ! + + +!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 10/23/2020 21:56:12'! +addMorphFrontFromWorldPosition: aMorph + + aMorph layoutSpec. + self addMorphFront: aMorph. + self layoutSubmorphs. +! ! + + +!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 10/23/2020 21:16:03'! +into: aMorph + | locationOrNil previousLast | + locationOrNil _ aMorph location. + currentMorph _ aMorph. + cti _ cti + 1. + transformations size < cti + ifTrue: [ + drawingMorphStack add: aMorph. + currentTransformation _ locationOrNil + ifNotNil: [ currentTransformation composedWith: locationOrNil] + ifNil: [ currentTransformation copy ]. + transformations add: currentTransformation ] + ifFalse: [ + drawingMorphStack at: cti put: aMorph. + previousLast _ currentTransformation. + locationOrNil + ifNil: [ + "Podriamos reusar la instancia si nos sirve." + currentTransformation _ previousLast copy. + transformations at: cti put: currentTransformation ] + ifNotNil: [ :location | + currentTransformation _ transformations at: cti. + "reuse the instance if possible" + (previousLast class == location class and: [ previousLast class == currentTransformation class ]) + ifTrue: [ + previousLast composedWith: location into: currentTransformation ] + ifFalse: [ + currentTransformation _ previousLast composedWith: location. + transformations at: cti put: currentTransformation ] + ] + ]! ! + +!MorphicCanvas methodsFor: 'private' stamp: 'jmv 10/23/2020 21:19:51'! +externalizeDisplayBounds: r from: aMorph + "r is a Rectangle, expressed in aMorph's coordinate system. + Answer another rectangle, that bounds r when translated to World coordinates" + + "Should translate only to whatever world or PasteUp we are displaying. + Fix when implementing multiple Canvases (Displays) showing different + (potentially nested Worlds)" + | inOwners owner | + self flag: #jmvVer2. + + inOwners _ aMorph location + ifNil: [ r ] + ifNotNil: [ :tx | tx displayBoundsOfTransformOf: r ]. + owner _ aMorph owner. + ^owner + ifNotNil: [ self externalizeDisplayBounds: inOwners from: owner] + ifNil: [ inOwners encompassingIntegerRectangle ]! ! + +!methodRemoval: MovableMorph #addMorphFrontFromWorldPosition: stamp: 'jmv 10/23/2020 22:46:05'! +MovableMorph removeSelector: #addMorphFrontFromWorldPosition:! +!methodRemoval: Morph #layoutSpec: stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #layoutSpec:! +!methodRemoval: Morph #referencePosition: stamp: 'jmv 10/23/2020 22:45:24'! +Morph removeSelector: #referencePosition:! +!methodRemoval: Morph #morphAlign:with: stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #morphAlign:with:! +!methodRemoval: Morph #rotation: stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #rotation:! +!methodRemoval: Morph #rotationDegrees: stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #rotationDegrees:! +!methodRemoval: Morph #orbitBy: stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #orbitBy:! +!methodRemoval: Morph #rotateBy: stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #rotateBy:! +!methodRemoval: Morph #minimumLayoutExtent stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #minimumLayoutExtent! +!methodRemoval: Morph #scaleBy: stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #scaleBy:! +!methodRemoval: Morph #layoutSpec stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #layoutSpec! +!methodRemoval: Morph #allocHeightForFactor: stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #allocHeightForFactor:! +!methodRemoval: Morph #allocWidthForFactor: stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #allocWidthForFactor:! +!methodRemoval: Morph #layoutSpecOrNil stamp: 'jmv 10/23/2020 22:44:05'! +Morph removeSelector: #layoutSpecOrNil! + +!Morph reorganize! +('accessing' adoptWidgetsColor: beSticky color location lock morphId resistsRemoval taskbar toggleStickiness unlock unlockContents) +('accessing - flags' isLayoutNeeded isRedrawNeeded isSubmorphRedrawNeeded layoutNeeded: needsRedraw: submorphNeedsRedraw: visible) +('accessing - properties' hasProperty: isLocked isSticky lock: name name: removeProperty: setProperty:toValue: sticky: valueOfProperty: valueOfProperty:ifAbsent: valueOfProperty:ifPresentDo:) +('as yet unclassified' canDiscardEdits disregardUnacceptedEdits whenUIinSafeState:) +('caching' clearId fullReleaseCachedState releaseCachedState) +('change reporting' addedMorph: invalidateDisplayRect:fromSubmorph:for: invalidateLocalRect:) +('classification' isWorldMorph) +('copying' copy copyForClipboard duplicate) +('debug and other' addDebuggingItemsTo:hand: buildDebugMenu: inspectOwnerChain ownerChain resumeAfterDrawError resumeAfterStepError) +('drawing' addPossiblyUncoveredAreasIn:to: drawOn: drawingFails drawingFailsNot hide icon imageForm: imageForm:depth: isKnownFailing refreshWorld show visible:) +('dropping/grabbing' aboutToBeGrabbedBy: aboutToGrab: acceptDroppingMorph:event: dropFiles: justDroppedInto:event: justGrabbedFrom: rejectDropMorphEvent: wantsDroppedMorph:event: wantsToBeDroppedInto:) +('e-toy support' embeddedInMorphicWindowLabeled: unlockOneSubpart wantsRecolorHandle) +('events' click:localPosition: doubleClick:localPosition: dragEvent:localPosition: keyDown: keyStroke: keyUp: mouseButton1Down:localPosition: mouseButton1Up:localPosition: mouseButton2Down:localPosition: mouseButton2Up:localPosition: mouseButton3Down:localPosition: mouseButton3Up:localPosition: mouseEnter: mouseHover:localPosition: mouseLeave: mouseMove:localPosition: mouseScroll:localPosition: mouseStillDown windowEvent:) +('event handling testing' allowsFilesDrop allowsMorphDrop allowsSubmorphDrag handlesKeyboard handlesMouseDown: handlesMouseHover handlesMouseOver: handlesMouseScroll: handlesMouseStillDown:) +('event handling' mouseButton2Activity mouseStillDownStepRate mouseStillDownThreshold) +('events-alarms' addAlarm:after: addAlarm:with:after: addAlarm:withArguments:after: alarmScheduler removeAlarm:) +('events-processing' dispatchEvent:localPosition: focusKeyboardFor: handleFocusEvent: processDropFiles:localPosition: processDropMorph:localPosition: processKeyDown:localPosition: processKeyUp:localPosition: processKeystroke:localPosition: processMouseDown:localPosition: processMouseEnter:localPosition: processMouseLeave:localPosition: processMouseMove:localPosition: processMouseOver:localPosition: processMouseScroll:localPosition: processMouseStillDown processMouseUp:localPosition: processUnknownEvent:localPosition: processWindowEvent:localPosition: rejectsEvent: rejectsEventFully:) +('fileIn/out' prepareToBeSaved storeDataOn:) +('focus handling' hasKeyboardFocus hasMouseFocus keyboardFocusChange:) +('geometry' displayBounds displayBounds: displayBoundsForHalo displayBoundsOrBogus displayFullBounds extentBorder externalize: externalizeDisplayBounds: externalizeDistance: externalizeDistanceToWorld: externalizeToWorld: fontPreferenceChanged internalize: internalizeDistance: internalizeDistanceFromWorld: internalizeFromWorld: minimumExtent morphExtent morphExtent: morphExtentInWorld morphExtentInWorld: morphHeight morphLocalBounds morphPosition morphPosition: morphPositionInWorld morphPositionInWorld: morphTopLeft morphWidth referencePosition rotation:scale: scale) +('geometry testing' clipsLastSubmorph fullContainsGlobalPoint: fullContainsPoint: isOrthoRectangularMorph morphContainsPoint: requiresVectorCanvas submorphsMightProtrude) +('halos and balloon help' addHalo addHalo: addHandlesTo:box: addOptionalHandlesTo:box: balloonHelpDelayTime balloonText comeToFrontAndAddHalo deleteBalloon editBalloonHelpContent: editBalloonHelpText halo mouseDownOnHelpHandle: noHelpString okayToBrownDragEasily okayToResizeEasily okayToRotateEasily removeHalo setBalloonText: showBalloon: showBalloon:hand: transferHalo:from: wantsBalloon wantsHalo wantsHaloHandleWithSelector:inHalo:) +('initialization' inATwoWayScrollPane initialize intoWorld: openInHand openInWorld openInWorld:) +('iteration of all morphs' nextMorph nextMorphPart2 nextMorphThat: previousMorph previousMorphThat:) +('layout' layoutSubmorphs layoutSubmorphsIfNeeded minItemWidth minimumLayoutHeight minimumLayoutWidth minimumShrinkExtent minimumShrinkHeight minimumShrinkWidth someSubmorphPositionOrExtentChanged) +('macpal' flash flashWith:) +('menus' addAddHandMenuItemsForHalo:hand: addColorMenuItems:hand: addCopyItemsTo: addCustomHaloMenuItems:hand: addCustomMenuItems:hand: addExportMenuItems:hand: addHaloActionsTo: addStandardHaloMenuItemsTo:hand: addTitleForHaloMenu: addToggleItemsToHaloMenu: changeColor expand exportAsBMP exportAsJPEG lockUnlockMorph lockedString maybeAddCollapseItemTo: stickinessString) +('meta-actions' addEmbeddingMenuItemsTo:hand: buildHandleMenu: copyToClipboard: dismissMorph duplicateMorph: maybeDuplicateMorph potentialEmbeddingTargets) +('naming' label) +('object serialization' objectForDataStream:) +('player' okayToDuplicate) +('printing' printOn:) +('rotate scale and flex' rotationDegrees) +('stepping' shouldGetStepsFrom: startStepping startStepping: startStepping:in:stepTime: startStepping:stepTime: startSteppingStepTime: step stepAt: stopStepping stopStepping: wantsSteps) +('structure' allOwnersDo: allOwnersReverseDo: firstOwnerSuchThat: hasOwner: isInWorld owner owningWindow root veryLastLeaf withAllOwnersDo: withAllOwnersReverseDo: world) +('submorphs-accessing' allMorphsDo: clippedSubmorph findDeepSubmorphThat:ifAbsent: findSubmorphBinary: firstSubmorph hasSubmorphs lastSubmorph noteNewOwner: submorphBehind: submorphCount submorphInFrontOf: submorphs submorphsBehind:do: submorphsDo: submorphsDrawingOutsideReverseDo: submorphsInFrontOf:do: submorphsReverseDo: submorphsSatisfying: unclippedSubmorphsReverseDo:) +('submorphs-add/remove' addAllMorphs: addAllMorphs:after: addMorph: addMorph:behind: addMorph:inFrontOf: addMorph:position: addMorphBack: addMorphBack:position: addMorphFront: addMorphFront:position: addMorphFrontFromWorldPosition: atFront canAdd: comeToFront delete dismissViaHalo goBehind privateDelete removeAllMorphs removeAllMorphsIn: removeMorph: removedMorph: replaceSubmorph:by:) +('testing' hasModel is: isCollapsed isOwnedByHand isOwnedByWorld isProportionalHeight isProportionalWidth isReallyVisible stepTime) +('updating' invalidateBounds redrawNeeded) +('user interface' activateWindow activateWindowAndSendTopToBack: collapse showAndComeToFront toggleCollapseOrShow) +('private' privateAddAllMorphs:atIndex: privateAddMorph:atIndex: privateAddMorph:atIndex:position: privateAnyOwnerHandlesMouseScroll: privateFlagAt: privateFlagAt:put: privateMoveBackMorph: privateMoveFrontMorph: privateOwner: privatePosition: privateRemove: privateSubmorphs) +('previewing' beginPreview endPreview endPreviewAndToggleCollapseOrShow morphBehindBeforePreview morphBehindBeforePreview: previewing previewing: visibleBeforePreview visibleBeforePreview:) +! + diff --git a/CoreUpdates/4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st b/CoreUpdates/4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st new file mode 100644 index 00000000..ddbbe9f4 --- /dev/null +++ b/CoreUpdates/4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st @@ -0,0 +1,62 @@ +'From Cuis 5.0 [latest update: #4424] on 23 October 2020 at 11:02:34 pm'! +"Change Set: 4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st +Date: 23 October 2020 +Author: Juan Vuletich + +Modifying class definition of core to Morphs is tricky. Hence this preamble." +| ui b cs d1 d2 | +Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. +(nil confirm: 'In order to modify instance definition of Morph and MovableMorph, +we need to restart the User Interface process. +You''ll need to do [Install New Updates] again, to install later updates.') ifFalse: [ self halt ]. +[ + ui _ UISupervisor ui. + UISupervisor stopUIProcess. + d1 _ IdentityDictionary new. + MovableMorph allSubInstancesDo: [ :m | + d2 _ Dictionary new. + d1 at: m put: d2. + d2 at: #location put: (m instVarNamed: 'location'). + d2 at: #layoutSpec put: (m instVarNamed: 'layoutSpec'). + d2 at: #properties put: (m instVarNamed: 'properties'). + d2 at: #id put: (m instVarNamed: 'id'). + d2 at: #privateDisplayBounds put: (m instVarNamed: 'privateDisplayBounds'). ]. + b _ ClassBuilder isSilent. + ClassBuilder beSilent: true. + [ + ClassBuilder new + superclass: Object + subclass: #Morph + instanceVariableNames: 'owner submorphs properties id privateDisplayBounds' + classVariableNames: 'LastMorphId' + poolDictionaries: '' + category: 'Morphic-Kernel'. + ] + on: InMidstOfFileinNotification, UndeclaredVariableWarning, PoolDefinitionNotification + do: [ :ex | ex resume: true ]. + ClassBuilder new + superclass: Morph + subclass: #MovableMorph + instanceVariableNames: 'location layoutSpec' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Kernel'. + ClassBuilder beSilent: b. + MovableMorph allSubInstancesDo: [ :m | + d2 _ d1 at: m. + m instVarNamed: 'properties' put: (d2 at: #properties). + m instVarNamed: 'id' put: (d2 at: #id). + m instVarNamed: 'privateDisplayBounds' put: (d2 at: #privateDisplayBounds). + m instVarNamed: 'location' put: (d2 at: #location). + m instVarNamed: 'layoutSpec' put: (d2 at: #layoutSpec). ]. + d1 _ nil. d2 _ nil. + UISupervisor spawnNewMorphicProcessFor: ui. + (Delay forSeconds: 1) wait. + ChangeSet installing: '4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st' do: []. + cs _ ChangeSet changeSetForBaseSystem. + (cs name beginsWith: '4425') ifTrue: [ + ChangeSet removeChangeSet: cs ]. + 'Done updating definition of LabelMorph.' print. + 'Installed ChangeSet: 4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st' print. + 'Please do [Install New Updates] again.' print. +] forkAt: 41! diff --git a/Packages/BaseImageTests.pck.st b/Packages/BaseImageTests.pck.st index 33662bd0..22cff3c0 100644 --- a/Packages/BaseImageTests.pck.st +++ b/Packages/BaseImageTests.pck.st @@ -1,6 +1,6 @@ -'From Cuis 5.0 [latest update: #4414] on 19 October 2020 at 4:14:33 pm'! +'From Cuis 5.0 [latest update: #4425] on 24 October 2020 at 5:06:52 pm'! 'Description ReturnNodeTest tests'! -!provides: 'BaseImageTests' 1 251! +!provides: 'BaseImageTests' 1 252! !requires: '__Refactoring-TestData__' 1 0 nil! SystemOrganization addCategory: 'BaseImageTests-Collections'! SystemOrganization addCategory: 'BaseImageTests-Kernel-Classes'! @@ -1277,16 +1277,6 @@ TestCase subclass: #TranscriptTest TranscriptTest class instanceVariableNames: ''! -!classDefinition: #ColorTest category: 'BaseImageTests-Graphics-Primitives'! -TestCase subclass: #ColorTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'BaseImageTests-Graphics-Primitives'! -!classDefinition: 'ColorTest class' category: 'BaseImageTests-Graphics-Primitives'! -ColorTest class - instanceVariableNames: ''! - !classDefinition: #RectangleTest category: 'BaseImageTests-Graphics-Primitives'! TestCase subclass: #RectangleTest instanceVariableNames: '' @@ -15344,7 +15334,7 @@ testInverseTransformation self assert: ((inverse internalizeDelta: 3@4) - (forward externalizeDelta: 3@4)) r < 0.0001. self assert: ((inverse internalizeScalar: 7) - (forward externalizeScalar: 7)) abs < 0.0001.! ! -!LayoutMorphTest methodsFor: 'tests' stamp: 'jmv 6/8/2020 11:13:14'! +!LayoutMorphTest methodsFor: 'tests' stamp: 'jmv 10/24/2020 16:52:18'! testLayout1 " self new testLayout1 @@ -15383,7 +15373,7 @@ testLayout1 addMorph: (r3c3 _ WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6)) layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). pane addMorph: row3 layoutSpec: (LayoutSpec fixedHeight: 60). - pane openInWorld: PasteUpMorph someInstance; morphExtent: 408@300. + pane openInWorld: UISupervisor ui; morphExtent: 408@300. UISupervisor ui doOneCycleNow. self assert: row1 morphWidth = (pane morphWidth - 10). @@ -15417,7 +15407,7 @@ testLayout1 pane delete! ! -!LayoutMorphTest methodsFor: 'tests' stamp: 'jmv 8/6/2020 14:18:58'! +!LayoutMorphTest methodsFor: 'tests' stamp: 'jmv 10/24/2020 16:52:35'! testLayout2 " self new testLayout2 @@ -15435,7 +15425,7 @@ testLayout2 addMorph: (c3 _ WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6)) layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 offAxisEdgeWeight: #center). pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane openInWorld: PasteUpMorph someInstance; morphExtent: 400@300. + pane openInWorld: UISupervisor ui; morphExtent: 400@300. UISupervisor ui doOneCycleNow. self assert: row morphWidth = (pane morphWidth - 10). @@ -15452,7 +15442,7 @@ testLayout2 pane delete! ! -!LayoutMorphTest methodsFor: 'tests' stamp: 'jmv 8/6/2020 14:19:55'! +!LayoutMorphTest methodsFor: 'tests' stamp: 'jmv 10/24/2020 16:52:42'! testLayout3 " self new testLayout3 @@ -15478,7 +15468,7 @@ testLayout3 addMorph: (c3 _ WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6)) layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 200). - pane openInWorld: PasteUpMorph someInstance; morphExtent: 400@300. + pane openInWorld: UISupervisor ui; morphExtent: 400@300. UISupervisor ui doOneCycleNow. self assert: row displayBounds left = (pane displayBounds left + 5). @@ -15627,13 +15617,13 @@ testTransform self assert: ((MorphicTranslation withTranslation: -2) transform: (4@ 2)) = (2@0). self assert: ((MorphicTranslation withTranslation: -4) transform: (2@ 2)) = (-2@-2)! ! -!WorldTest methodsFor: 'tests' stamp: 'jmv 12/28/2017 16:11:35'! +!WorldTest methodsFor: 'tests' stamp: 'jmv 10/24/2020 15:58:12'! testDoOneCycleWorksWithDeferredQueue "Ensure that nested doOneCycles don't break deferred UI messages" | finished | [ - WorldState addDeferredUIMessage: [ UISupervisor ui doOneCycleNow ]. - WorldState addDeferredUIMessage: nil "whatever". + UISupervisor whenUIinSafeState:[ UISupervisor ui doOneCycleNow ]. + UISupervisor whenUIinSafeState: nil "whatever". UISupervisor ui doOneCycleNow. finished _ true. ] valueWithin: 1 seconds onTimeout: [finished _ false ]. @@ -16471,13 +16461,13 @@ isAbstract ^DynamicTypingSmalltalkCompleter isForCurrentTypeSystem not! ! -!TaskbarTest methodsFor: 'Running' stamp: 'jmv 12/28/2017 16:13:47'! +!TaskbarTest methodsFor: 'Running' stamp: 'jmv 10/24/2020 15:55:32'! setUp needsDelete _ UISupervisor ui taskbar isNil. taskbar _ UISupervisor ui hideTaskbar; showTaskbar; taskbar. taskbar screenSizeChanged. - taskbar world instVarNamed: 'worldState' :: runStepMethods! ! + taskbar world runStepMethods! ! !TaskbarTest methodsFor: 'Running' stamp: 'jmv 12/28/2017 16:12:13'! tearDown @@ -23931,11 +23921,6 @@ assertTranscriptContentsDoesNotChangeAfter: aBlock self assertTranscriptContentsAdded: '' after: aBlock! ! -!ColorTest methodsFor: 'testing' stamp: 'jpb 8/2/2019 23:28:54'! -testIsColor - self assert: (Color red is: #Color). - self assert: (Color random is: #Color).! ! - !RectangleTest methodsFor: 'testing' stamp: 'jpb 8/2/2019 23:52:04'! testIsRectangle self assert: (Rectangle new is: #Rectangle)! ! diff --git a/Packages/Features/VectorGraphics.pck.st b/Packages/Features/VectorGraphics.pck.st index 79789298..9fd302f5 100644 --- a/Packages/Features/VectorGraphics.pck.st +++ b/Packages/Features/VectorGraphics.pck.st @@ -1,361 +1,351 @@ -'From Cuis 5.0 [latest update: #4370] on 4 September 2020 at 11:14:15 am'! +'From Cuis 5.0 [latest update: #4425] on 24 October 2020 at 5:07:25 pm'! 'Description '! -!provides: 'VectorGraphics' 1 170! +!provides: 'VectorGraphics' 1 171! !requires: 'Collections-CompactArrays' 1 10 nil! -SystemOrganization addCategory: #'VectorGraphics-Kernel'! -SystemOrganization addCategory: #'VectorGraphics-TrueType'! -SystemOrganization addCategory: #'VectorGraphics-Experiments'! -SystemOrganization addCategory: #'VectorGraphics-PathCommands'! -SystemOrganization addCategory: #'VectorGraphics-Examples'! +SystemOrganization addCategory: 'VectorGraphics-Kernel'! +SystemOrganization addCategory: 'VectorGraphics-TrueType'! +SystemOrganization addCategory: 'VectorGraphics-Experiments'! +SystemOrganization addCategory: 'VectorGraphics-PathCommands'! +SystemOrganization addCategory: 'VectorGraphics-Examples'! -!classDefinition: #PathCommandError category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathCommandError category: 'VectorGraphics-PathCommands'! Error subclass: #PathCommandError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathCommandError class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathCommandError class' category: 'VectorGraphics-PathCommands'! PathCommandError class instanceVariableNames: ''! -!classDefinition: #TrueTypeFont category: #'VectorGraphics-TrueType'! +!classDefinition: #TrueTypeFont category: 'VectorGraphics-TrueType'! AbstractFont subclass: #TrueTypeFont instanceVariableNames: 'ttFontDescription pointSize emphasis glyphForms glyphFormsByUtf8 family baseFont derivativeFonts' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'TrueTypeFont class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'TrueTypeFont class' category: 'VectorGraphics-TrueType'! TrueTypeFont class instanceVariableNames: ''! -!classDefinition: #TrueTypeFontFamily category: #'VectorGraphics-TrueType'! +!classDefinition: #TrueTypeFontFamily category: 'VectorGraphics-TrueType'! FontFamily subclass: #TrueTypeFontFamily instanceVariableNames: 'baseTTFontDescription ttFontDescriptionsByEmphasis' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'TrueTypeFontFamily class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'TrueTypeFontFamily class' category: 'VectorGraphics-TrueType'! TrueTypeFontFamily class instanceVariableNames: ''! -!classDefinition: #EllipseMorph2 category: #'VectorGraphics-Experiments'! -Morph subclass: #EllipseMorph2 +!classDefinition: #EllipseMorph3 category: 'VectorGraphics-Experiments'! +MovableMorph subclass: #EllipseMorph3 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Experiments'! -!classDefinition: 'EllipseMorph2 class' category: #'VectorGraphics-Experiments'! -EllipseMorph2 class - instanceVariableNames: ''! - -!classDefinition: #EllipseMorph3 category: #'VectorGraphics-Experiments'! -Morph subclass: #EllipseMorph3 - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'VectorGraphics-Experiments'! -!classDefinition: 'EllipseMorph3 class' category: #'VectorGraphics-Experiments'! +!classDefinition: 'EllipseMorph3 class' category: 'VectorGraphics-Experiments'! EllipseMorph3 class instanceVariableNames: ''! -!classDefinition: #EllipseMorph4 category: #'VectorGraphics-Experiments'! -Morph subclass: #EllipseMorph4 +!classDefinition: #EllipseMorph4 category: 'VectorGraphics-Experiments'! +MovableMorph subclass: #EllipseMorph4 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Experiments'! -!classDefinition: 'EllipseMorph4 class' category: #'VectorGraphics-Experiments'! +!classDefinition: 'EllipseMorph4 class' category: 'VectorGraphics-Experiments'! EllipseMorph4 class instanceVariableNames: ''! -!classDefinition: #M3Exp01Morph category: #'VectorGraphics-Experiments'! -Morph subclass: #M3Exp01Morph +!classDefinition: #M3Exp01Morph category: 'VectorGraphics-Experiments'! +MovableMorph subclass: #M3Exp01Morph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Experiments'! -!classDefinition: 'M3Exp01Morph class' category: #'VectorGraphics-Experiments'! +!classDefinition: 'M3Exp01Morph class' category: 'VectorGraphics-Experiments'! M3Exp01Morph class instanceVariableNames: ''! -!classDefinition: #M3Exp02Morph category: #'VectorGraphics-Experiments'! -Morph subclass: #M3Exp02Morph +!classDefinition: #M3Exp02Morph category: 'VectorGraphics-Experiments'! +MovableMorph subclass: #M3Exp02Morph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Experiments'! -!classDefinition: 'M3Exp02Morph class' category: #'VectorGraphics-Experiments'! +!classDefinition: 'M3Exp02Morph class' category: 'VectorGraphics-Experiments'! M3Exp02Morph class instanceVariableNames: ''! -!classDefinition: #M3Exp03Morph category: #'VectorGraphics-Experiments'! -Morph subclass: #M3Exp03Morph +!classDefinition: #M3Exp03Morph category: 'VectorGraphics-Experiments'! +MovableMorph subclass: #M3Exp03Morph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Experiments'! -!classDefinition: 'M3Exp03Morph class' category: #'VectorGraphics-Experiments'! +!classDefinition: 'M3Exp03Morph class' category: 'VectorGraphics-Experiments'! M3Exp03Morph class instanceVariableNames: ''! -!classDefinition: #ClockMorph category: #'VectorGraphics-Examples'! -Morph subclass: #ClockMorph +!classDefinition: #ClockMorph category: 'VectorGraphics-Examples'! +MovableMorph subclass: #ClockMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Examples'! -!classDefinition: 'ClockMorph class' category: #'VectorGraphics-Examples'! +!classDefinition: 'ClockMorph class' category: 'VectorGraphics-Examples'! ClockMorph class instanceVariableNames: ''! -!classDefinition: #HybridCanvas category: #'VectorGraphics-Kernel'! +!classDefinition: #HybridCanvas category: 'VectorGraphics-Kernel'! BitBltCanvas subclass: #HybridCanvas instanceVariableNames: 'vectorCanvas' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Kernel'! -!classDefinition: 'HybridCanvas class' category: #'VectorGraphics-Kernel'! +!classDefinition: 'HybridCanvas class' category: 'VectorGraphics-Kernel'! HybridCanvas class instanceVariableNames: ''! -!classDefinition: #VectorCanvas category: #'VectorGraphics-Kernel'! +!classDefinition: #VectorCanvas category: 'VectorGraphics-Kernel'! MorphicCanvas subclass: #VectorCanvas instanceVariableNames: 'boundsFinderEngine' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Kernel'! -!classDefinition: 'VectorCanvas class' category: #'VectorGraphics-Kernel'! +!classDefinition: 'VectorCanvas class' category: 'VectorGraphics-Kernel'! VectorCanvas class instanceVariableNames: ''! -!classDefinition: #VectorEngineAbstract category: #'VectorGraphics-Kernel'! +!classDefinition: #VectorEngineAbstract category: 'VectorGraphics-Kernel'! Object subclass: #VectorEngineAbstract instanceVariableNames: 'targetForm morphIds targetWidth antiAliasingWidth strokeWidth geometryTransformation currentMorphId clippingMorphId morphBoundsLeft morphBoundsTop morphBoundsRight morphBoundsBottom hopsPerPixel pathFirstX pathFirstY pathCurrentX pathCurrentY previousCallX previousCallY previousCallControlX previousCallControlY' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Kernel'! -!classDefinition: 'VectorEngineAbstract class' category: #'VectorGraphics-Kernel'! +!classDefinition: 'VectorEngineAbstract class' category: 'VectorGraphics-Kernel'! VectorEngineAbstract class instanceVariableNames: ''! -!classDefinition: #VectorEngineBoundsFinder category: #'VectorGraphics-Kernel'! +!classDefinition: #VectorEngineBoundsFinder category: 'VectorGraphics-Kernel'! VectorEngineAbstract subclass: #VectorEngineBoundsFinder instanceVariableNames: 'auxStrokeWidthDilatedHalf' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Kernel'! -!classDefinition: 'VectorEngineBoundsFinder class' category: #'VectorGraphics-Kernel'! +!classDefinition: 'VectorEngineBoundsFinder class' category: 'VectorGraphics-Kernel'! VectorEngineBoundsFinder class instanceVariableNames: ''! -!classDefinition: #VectorEngineSubPixel category: #'VectorGraphics-Kernel'! +!classDefinition: #VectorEngineSubPixel category: 'VectorGraphics-Kernel'! VectorEngineAbstract subclass: #VectorEngineSubPixel instanceVariableNames: 'edgeCounts alphaMask blendLeft blendTop blendRight blendBottom strokeColor fillColor clipLeft clipTop clipRight clipBottom prevYTruncated auxAntiAliasingWidthScaledInverse auxStrokeWidthDilatedHalf auxStrokeWidthDilatedHalfSquared auxStrokeWidthErodedHalfSquared subPixelDelta' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Kernel'! -!classDefinition: 'VectorEngineSubPixel class' category: #'VectorGraphics-Kernel'! +!classDefinition: 'VectorEngineSubPixel class' category: 'VectorGraphics-Kernel'! VectorEngineSubPixel class instanceVariableNames: ''! -!classDefinition: #VectorEngineWholePixel category: #'VectorGraphics-Kernel'! +!classDefinition: #VectorEngineWholePixel category: 'VectorGraphics-Kernel'! VectorEngineAbstract subclass: #VectorEngineWholePixel instanceVariableNames: 'edgeCounts alphaMask blendLeft blendTop blendRight blendBottom strokeColor fillColor clipLeft clipTop clipRight clipBottom prevYTruncated auxAntiAliasingWidthScaledInverse auxStrokeWidthDilatedHalf auxStrokeWidthDilatedHalfSquared auxStrokeWidthErodedHalfSquared' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-Kernel'! -!classDefinition: 'VectorEngineWholePixel class' category: #'VectorGraphics-Kernel'! +!classDefinition: 'VectorEngineWholePixel class' category: 'VectorGraphics-Kernel'! VectorEngineWholePixel class instanceVariableNames: ''! -!classDefinition: #FormGlyph category: #'VectorGraphics-TrueType'! +!classDefinition: #FormGlyph category: 'VectorGraphics-TrueType'! Object subclass: #FormGlyph instanceVariableNames: 'form leftOffset topOffset advanceWidth' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'FormGlyph class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'FormGlyph class' category: 'VectorGraphics-TrueType'! FormGlyph class instanceVariableNames: ''! -!classDefinition: #TTContourConstruction category: #'VectorGraphics-TrueType'! +!classDefinition: #TTContourConstruction category: 'VectorGraphics-TrueType'! Object subclass: #TTContourConstruction instanceVariableNames: 'points controlPointFlags' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'TTContourConstruction class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'TTContourConstruction class' category: 'VectorGraphics-TrueType'! TTContourConstruction class instanceVariableNames: ''! -!classDefinition: #TTFontDescription category: #'VectorGraphics-TrueType'! +!classDefinition: #TTFontDescription category: 'VectorGraphics-TrueType'! Object subclass: #TTFontDescription instanceVariableNames: 'folderName contourDataForIso8859s15 contourDataIndexesByIso8859s15 contourDataIndexesForSmalltalkGlyphs contourDataForUtf8 contourDataIndexesByUtf8 kernPairs copyright familyName fullName subfamilyName uniqueName versionName postscriptName trademark bounds unitsPerEm ascent descent lineGap letterMTopSideBearing' classVariableNames: 'Descriptions' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'TTFontDescription class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'TTFontDescription class' category: 'VectorGraphics-TrueType'! TTFontDescription class instanceVariableNames: ''! -!classDefinition: #TTFontReader category: #'VectorGraphics-TrueType'! +!classDefinition: #TTFontReader category: 'VectorGraphics-TrueType'! Object subclass: #TTFontReader instanceVariableNames: 'glyphs nGlyphs kernPairs fontDescription' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'TTFontReader class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'TTFontReader class' category: 'VectorGraphics-TrueType'! TTFontReader class instanceVariableNames: ''! -!classDefinition: #TTFontTableDirEntry category: #'VectorGraphics-TrueType'! +!classDefinition: #TTFontTableDirEntry category: 'VectorGraphics-TrueType'! Object subclass: #TTFontTableDirEntry instanceVariableNames: 'tag fontData offset length checkSum' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'TTFontTableDirEntry class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'TTFontTableDirEntry class' category: 'VectorGraphics-TrueType'! TTFontTableDirEntry class instanceVariableNames: ''! -!classDefinition: #TTGlyph category: #'VectorGraphics-TrueType'! +!classDefinition: #TTGlyph category: 'VectorGraphics-TrueType'! Object subclass: #TTGlyph instanceVariableNames: 'boundsLeft boundsRight boundsTop boundsBottom contours advanceWidth leftSideBearing rightSideBearing' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'TTGlyph class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'TTGlyph class' category: 'VectorGraphics-TrueType'! TTGlyph class instanceVariableNames: ''! -!classDefinition: #TTCompositeGlyph category: #'VectorGraphics-TrueType'! +!classDefinition: #TTCompositeGlyph category: 'VectorGraphics-TrueType'! TTGlyph subclass: #TTCompositeGlyph instanceVariableNames: 'glyphs' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'TTCompositeGlyph class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'TTCompositeGlyph class' category: 'VectorGraphics-TrueType'! TTCompositeGlyph class instanceVariableNames: ''! -!classDefinition: #TTKernPair category: #'VectorGraphics-TrueType'! +!classDefinition: #TTKernPair category: 'VectorGraphics-TrueType'! Object subclass: #TTKernPair instanceVariableNames: 'left right value mask' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-TrueType'! -!classDefinition: 'TTKernPair class' category: #'VectorGraphics-TrueType'! +!classDefinition: 'TTKernPair class' category: 'VectorGraphics-TrueType'! TTKernPair class instanceVariableNames: ''! -!classDefinition: #PathCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathCommand category: 'VectorGraphics-PathCommands'! Object subclass: #PathCommand instanceVariableNames: 'coordinatesAreRelative' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathCommand class' category: 'VectorGraphics-PathCommands'! PathCommand class instanceVariableNames: ''! -!classDefinition: #PathArcCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathArcCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathArcCommand instanceVariableNames: 'rs xAxisRotations toPoints doLargerArcs useIncreasingAngless' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathArcCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathArcCommand class' category: 'VectorGraphics-PathCommands'! PathArcCommand class instanceVariableNames: ''! -!classDefinition: #PathCloseCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathCloseCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathCloseCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathCloseCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathCloseCommand class' category: 'VectorGraphics-PathCommands'! PathCloseCommand class instanceVariableNames: ''! -!classDefinition: #PathCurveToCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathCurveToCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathCurveToCommand instanceVariableNames: 'toPoints control1Points control2Points' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathCurveToCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathCurveToCommand class' category: 'VectorGraphics-PathCommands'! PathCurveToCommand class instanceVariableNames: ''! -!classDefinition: #PathCurveToSmoothCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathCurveToSmoothCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathCurveToSmoothCommand instanceVariableNames: 'toPoints control2Points' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathCurveToSmoothCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathCurveToSmoothCommand class' category: 'VectorGraphics-PathCommands'! PathCurveToSmoothCommand class instanceVariableNames: ''! -!classDefinition: #PathLineToCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathLineToCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathLineToCommand instanceVariableNames: 'points' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathLineToCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathLineToCommand class' category: 'VectorGraphics-PathCommands'! PathLineToCommand class instanceVariableNames: ''! -!classDefinition: #PathLineToHCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathLineToHCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathLineToHCommand instanceVariableNames: 'xs' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathLineToHCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathLineToHCommand class' category: 'VectorGraphics-PathCommands'! PathLineToHCommand class instanceVariableNames: ''! -!classDefinition: #PathLineToVCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathLineToVCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathLineToVCommand instanceVariableNames: 'ys' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathLineToVCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathLineToVCommand class' category: 'VectorGraphics-PathCommands'! PathLineToVCommand class instanceVariableNames: ''! -!classDefinition: #PathMoveToCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathMoveToCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathMoveToCommand instanceVariableNames: 'points' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathMoveToCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathMoveToCommand class' category: 'VectorGraphics-PathCommands'! PathMoveToCommand class instanceVariableNames: ''! -!classDefinition: #PathQuadraticCurveToCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathQuadraticCurveToCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathQuadraticCurveToCommand instanceVariableNames: 'toPoints controlPoints' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathQuadraticCurveToCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathQuadraticCurveToCommand class' category: 'VectorGraphics-PathCommands'! PathQuadraticCurveToCommand class instanceVariableNames: ''! -!classDefinition: #PathQuadraticCurveToSmoothCommand category: #'VectorGraphics-PathCommands'! +!classDefinition: #PathQuadraticCurveToSmoothCommand category: 'VectorGraphics-PathCommands'! PathCommand subclass: #PathQuadraticCurveToSmoothCommand instanceVariableNames: 'toPoints' classVariableNames: '' poolDictionaries: '' category: 'VectorGraphics-PathCommands'! -!classDefinition: 'PathQuadraticCurveToSmoothCommand class' category: #'VectorGraphics-PathCommands'! +!classDefinition: 'PathQuadraticCurveToSmoothCommand class' category: 'VectorGraphics-PathCommands'! PathQuadraticCurveToSmoothCommand class instanceVariableNames: ''! @@ -367,16 +357,6 @@ In Cuis what is usually called TrueType Font is represented by TTFontDescription TrueTypeFonts, being part of the traditional AbstractFont hierarchy, adds a specific pointSize, and is the object used in texts.! -!EllipseMorph2 commentStamp: '' prior: 0! -self runningWorld setCanvas: (HybridCanvas onForm: Display). -self runningWorld setCanvas: (BitBltCanvas onForm: Display). -self runningWorld canvas class. - -"Hide taskbar." - -EllipseMorph2 new openInWorld. -EllipseMorph2 allInstancesDo: [ :a | a delete ]! - !EllipseMorph3 commentStamp: '' prior: 0! " self runningWorld setCanvas: (HybridCanvas onForm: Display). @@ -992,30 +972,6 @@ serviceReadTTFont icon: ((Theme content from: 'Theme' get: {'16x16'. 'mimetypes'}) at: 'font-x-generic.png') ) argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!EllipseMorph2 methodsFor: 'drawing' stamp: 'jmv 7/14/2020 22:06:01'! -drawOn: aCanvas - - aCanvas ellipseCenterX: 0 y: 0 rx: 100 ry: 6 borderWidth: 6 borderColor: Color gray fillColor: Color black! ! - -!EllipseMorph2 methodsFor: 'stepping' stamp: 'jmv 7/14/2020 22:06:54'! -stepAt: millisecondSinceLast - "See comment at #wantsSteps" - self rotateBy: Float twoPi / 60! ! - -!EllipseMorph2 methodsFor: 'stepping' stamp: 'jmv 7/14/2020 21:36:57'! -wantsSteps - ^true! ! - -!EllipseMorph2 methodsFor: 'geometry' stamp: 'jmv 7/14/2020 22:18:25'! -morphExtentInWorld: newExtent - "world coordinates - Ignored by morphs that are not resizeable" - self scaleBy: newExtent magnitude / (100*location scale)! ! - -!EllipseMorph2 class methodsFor: 'new-morph participation' stamp: 'jmv 7/9/2020 16:50:50'! -categoryInNewMorphMenu - ^ 'Basic'! ! - !EllipseMorph3 methodsFor: 'drawing' stamp: 'jmv 7/27/2020 01:25:30'! drawOn: aCanvas aCanvas ellipseCenterX: 0 y: 0 rx: 98 ry: 50 borderWidth: 3 borderColor: Color black fillColor: (Color r: 0.000 g: 0.000 b: 1.000).! ! @@ -1188,10 +1144,10 @@ step wantsSteps ^true! ! -!HybridCanvas methodsFor: 'initialization' stamp: 'jmv 7/11/2020 00:07:15'! -world: aPasteUpMorph - super world: aPasteUpMorph. - vectorCanvas world: aPasteUpMorph! ! +!HybridCanvas methodsFor: 'initialization' stamp: 'jmv 10/24/2020 16:04:17'! +world: aWorldMorph + super world: aWorldMorph. + vectorCanvas world: aWorldMorph! ! !HybridCanvas methodsFor: 'private' stamp: 'jmv 7/11/2020 09:55:52'! canvasToUse @@ -1276,9 +1232,11 @@ savePatch: prevSavedPatch bounds: aRectangle ^ vectorCanvas savePatch: prevSavedPatch bounds: aRectangle! ! -!HybridCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 22:10:11'! -drawWorld: aPasteUpMorph rects: allDamage - "Draw allDamage rects for aPasteUpMorph" +!HybridCanvas methodsFor: 'morphic world' stamp: 'jmv 10/24/2020 17:05:13'! +drawWorldBackground: aWorldMorph rects: worldBackgroundDamage + "Draw worldBackgroundDamage rects for aWorldMorph. + Do not include submorphs." + | auxBitBlt hack | self flag: #jmvHacks. @@ -1286,8 +1244,8 @@ drawWorld: aPasteUpMorph rects: allDamage auxBitBlt _ BitBlt toForm: hack. auxBitBlt fillBitmap: (Bitmap with: 16r00000000). auxBitBlt combinationRule: Form over. - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r). + worldBackgroundDamage do: [ :r | + aWorldMorph drawOn: (self newClipRect: r). auxBitBlt destRect: r. auxBitBlt copyBits ]. diff --git a/Packages/Features/Wallpaper.pck.st b/Packages/Features/Wallpaper.pck.st index e423dc96..302e893f 100644 --- a/Packages/Features/Wallpaper.pck.st +++ b/Packages/Features/Wallpaper.pck.st @@ -1,23 +1,23 @@ -'From Cuis 5.0 [latest update: #4048] on 26 February 2020 at 1:51:36 pm'! +'From Cuis 5.0 [latest update: #4425] on 24 October 2020 at 5:07:51 pm'! 'Description '! -!provides: 'Wallpaper' 1 4! +!provides: 'Wallpaper' 1 5! !requires: 'Graphics-Files-Additional' 1 22 nil! -SystemOrganization addCategory: #Wallpaper! +SystemOrganization addCategory: 'Wallpaper'! -!classDefinition: #WallpaperChanger category: #Wallpaper! +!classDefinition: #WallpaperChanger category: 'Wallpaper'! Object subclass: #WallpaperChanger instanceVariableNames: 'world' classVariableNames: '' poolDictionaries: '' category: 'Wallpaper'! -!classDefinition: 'WallpaperChanger class' category: #Wallpaper! +!classDefinition: 'WallpaperChanger class' category: 'Wallpaper'! WallpaperChanger class instanceVariableNames: ''! -!WallpaperChanger commentStamp: 'EB 4/24/2019 17:53:39' prior: 0! -Changes the wallpaper of a given PasteUpMorph. +!WallpaperChanger commentStamp: 'jmv 10/24/2020 16:54:40' prior: 0! +Changes the wallpaper of a given WorldMorph. Example usage: