[squeak-dev] The Trunk: MorphicWiW-ar.1.mcz

Andreas Raab uploaded a new version of MorphicWiW to project The Trunk:
http://source.squeak.org/trunk/MorphicWiW-ar.1.mcz

==================== Summary ====================

Name: MorphicWiW-ar.1
Author: ar
Time: 19 September 2009, 8:34:42 am
UUID: 2db8be34-2f7e-a34b-ace4-f200f619b5f3
Ancestors:

Package containing the (retired) Morphic World-in-World facilities.

==================== Snapshot ====================

SystemOrganization addCategory: #'MorphicWiW-ST80'!
SystemOrganization addCategory: #'MorphicWiW-Basic'!

SystemWindow subclass: #NewWorldWindow
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicWiW-Basic'!

----- Method: NewWorldWindow>>addMorph:frame: (in category 'panes') -----
addMorph: aMorph frame: relFrame
        | cc |
        cc := aMorph color.
        super addMorph: aMorph frame: relFrame.
        aMorph color: cc.!

----- Method: NewWorldWindow>>amendSteppingStatus (in category 'stepping') -----
amendSteppingStatus!

----- Method: NewWorldWindow>>openInWorld: (in category 'initialization') -----
openInWorld: aWorld
        | xxx |
        "This msg and its callees result in the window being activeOnlyOnTop"

        xxx := RealEstateAgent initialFrameFor: self world: aWorld.

        "Bob say: 'opening in ',xxx printString,' out of ',aWorld bounds printString.
        6 timesRepeat: [Display flash: xxx andWait: 300]."

        self bounds: xxx.
        ^self openAsIsIn: aWorld.!

----- Method: NewWorldWindow>>setStripeColorsFrom: (in category 'label') -----
setStripeColorsFrom: paneColor
        "Since our world may be *any* color, try to avoid really dark colors so title will show"

        | revisedColor |
        stripes ifNil: [^ self].
        revisedColor := paneColor atLeastAsLuminentAs: 0.1 .
        self isActive ifTrue:
                [stripes second
                        color: revisedColor;
                        borderColor: stripes second color darker.
                stripes first
                        color: stripes second borderColor darker;
                        borderColor: stripes first color darker.
                ^ self].
        "This could be much faster"
        stripes second
                color: revisedColor;
                borderColor: revisedColor.
        stripes first
                color: revisedColor;
                borderColor: revisedColor!

----- Method: NewWorldWindow>>setWindowColor: (in category 'color') -----
setWindowColor: incomingColor
        | existingColor aColor |

        incomingColor ifNil: [^ self].  "it happens"
        aColor := incomingColor asNontranslucentColor.
        (aColor = ColorPickerMorph perniciousBorderColor
                or: [aColor = Color black]) ifTrue: [^ self].
        existingColor := self paneColorToUse.
        existingColor ifNil: [^ Beeper beep].
        self setStripeColorsFrom: aColor
               
!

----- Method: NewWorldWindow>>updatePaneColors (in category 'panes') -----
updatePaneColors
        "Useful when changing from monochrome to color display"

        self setStripeColorsFrom: self paneColorToUse.

        "paneMorphs do: [:p | p color: self paneColorToUse]." "since pane is a world, skip this"
!

----- Method: NewWorldWindow>>wantsSteps (in category 'testing') -----
wantsSteps
       
        ^true!

SystemWindow subclass: #WorldWindow
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicWiW-Basic'!

!WorldWindow commentStamp: '<historical>' prior: 0!
A WorldWindow is a SystemWindow whose central area presents an inner Morphic world.

WorldWindows have a red title bar when the world inside is inactive. This changes to green when the world becomes the active world. The world inside becomes activated by clicking in it. When you click outside this world, the parent world resumes control. While its world is inactive, the WorldWindow may be moved and resized like any other.

It would be nice to make the world inside active whenever the WorldWindow was active, but this presents difficulties in moving and resizing, probably related to use of the global World instead of self world in many methods.

This facility is mainly the work of Bob Arning, with a number of tweaks by DI.
!

----- Method: WorldWindow class>>test1 (in category 'as yet unclassified') -----
test1
        "WorldWindow test1."

        | window world |
        world := WiWPasteUpMorph newWorldForProject: nil.
        window := (WorldWindow labelled: 'Inner World') model: world.
        window addMorph: world.
        world hostWindow: window.
        window openInWorld
!

----- Method: WorldWindow class>>test2 (in category 'as yet unclassified') -----
test2
        "WorldWindow test2."

        | window world scrollPane |
        world := WiWPasteUpMorph newWorldForProject: nil.
        window := (WorldWindow labelled: 'Scrollable World') model: world.
        window addMorph: (scrollPane := TwoWayScrollPane new model: world)
                frame: (0@0 extent: 1.0@1.0).
        scrollPane scroller addMorph: world.
        world hostWindow: window.
        window openInWorld
!

----- Method: WorldWindow>>buildWindowMenu (in category 'menu') -----
buildWindowMenu

        | aMenu |
        aMenu := super buildWindowMenu.
        {640@480. 800@600. 832@624. 1024@768} do: [ :each |
                aMenu
                        add: each x printString,' x ',each y printString
                        target: self
                        selector: #extent:
                        argument: each + (0@self labelHeight).
        ].
        ^aMenu!

----- Method: WorldWindow>>collapseOrExpand (in category 'resize/collapse') -----
collapseOrExpand

        super collapseOrExpand.
        isCollapsed ifFalse: [model becomeTheActiveWorldWith: nil]!

----- Method: WorldWindow>>extent: (in category 'geometry') -----
extent: x

        super extent: x.
        model ifNil: [^self].
        model extent: self panelRect extent.!

----- Method: WorldWindow>>fullBounds (in category 'layout') -----
fullBounds

        ^self bounds!

----- Method: WorldWindow>>mouseUp: (in category 'event handling') -----
mouseUp: evt

        (self panelRect containsPoint: evt cursorPoint)
                ifTrue: [model becomeTheActiveWorldWith: evt]!

----- Method: WorldWindow>>openInWorld: (in category 'initialization') -----
openInWorld: aWorld
        "This msg and its callees result in the window being activeOnlyOnTop"
        self bounds: (RealEstateAgent initialFrameFor: self world: aWorld).
        self firstSubmorph position: (self left + 1) @ (self top + self labelHeight).
        ^self openAsIsIn: aWorld!

Controller subclass: #MorphWorldController
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicWiW-ST80'!

!MorphWorldController commentStamp: '<historical>' prior: 0!
I am a controller for SceneViews. I support gestures for scrolling, click-selection, and area selection of scene glyphs. (See the class comment in GestureController for more details about gestures.) I also support construction operations such as inserting new glyphs and merging glyphs to make them share a common point.

The mapping of gestures to actions is as follows (see GestureController comment for more about gestures):

  Click:
        click on glyph select glyph
        shift-click on glyph toggle selection of that glyph
        click on background clear selection
  Double click:
        double-click on glyph inspect glyph
        double-click on background select all
  Hold/Drag/Sweep:
        hold (no movement) yellow-button menu
        drag (up/left movement) scrolling hand
        sweep (down/right movement) select glyphs in region
        shift-sweep toggle selection of glyphs in region
!

----- Method: MorphWorldController>>controlActivity (in category 'control defaults') -----
controlActivity
        "Do one step of the Morphic interaction loop. Called repeatedly while window is active."

        model doOneCycle.
!

----- Method: MorphWorldController>>controlInitialize (in category 'basic control sequence') -----
controlInitialize
        "This window is becoming active."

        true ifTrue: [model becomeTheActiveWorldWith: nil].

        model canvas ifNil: [  "i.e., only on first entry"
                "In case of, eg, inspect during balloon help..."
                model submorphsDo: [:m |  "delete any existing balloons"
                        (m isKindOf: BalloonMorph) ifTrue: [m delete]].

                model handsDo: [:h | h initForEvents].
                view displayView].  "initializes the WorldMorph's canvas"
!

----- Method: MorphWorldController>>controlLoop (in category 'basic control sequence') -----
controlLoop
        "Overridden to keep control active when the hand goes out of the view"

        | db |
        [self viewHasCursor  "working in the window"
                or: [Sensor noButtonPressed  "wandering with no button pressed"
                or: [model primaryHand submorphs size > 0  "dragging something outside"]]]
                whileTrue:   "... in other words anything but clicking outside"
                        [self controlActivity.

                        "Check for reframing since we hold control here"
                        db := view superView displayBox.
                        view superView controller checkForReframe.
                        db = view superView displayBox ifFalse:
                                [self controlInitialize "reframe world if bounds changed"]].
!

----- Method: MorphWorldController>>controlTerminate (in category 'basic control sequence') -----
controlTerminate
        "This window is becoming inactive; restore the normal cursor."

        Cursor normal show.
        ActiveWorld := ActiveHand := ActiveEvent := nil!

----- Method: MorphWorldController>>isControlActive (in category 'control defaults') -----
isControlActive

        ^ sensor redButtonPressed or: [self viewHasCursor]!

View subclass: #MorphWorldView
        instanceVariableNames: ''
        classVariableNames: 'FullColorWhenInactive'
        poolDictionaries: ''
        category: 'MorphicWiW-ST80'!

!MorphWorldView commentStamp: '<historical>' prior: 0!
I am a view used to display a Scene. I may be scrolled by adjusting my offset. My default controller is SceneController.

SceneViews encapsulate the notion of a changing foreground and a fixed background during interactive updates. During an interaction (such as dragging), some of the glyphs will not change location or appearance. These are part of the "background". All glyphs that may change (the "foreground" glyphs) are painted against this unchanging backdrop during the interaction.

Instance Variables:
        offset the current offset of this view (used for scrolling)
        enclosingRect a rectangle large enough to contain all the objects in the scene, plus a small border (this is a cache that must be recomputed when glyphs are moved, added, or removed from the scene)
        backgroundForm a <Form> containing the fixed background
        visibleForeground the glyphs that are changing but not selected during an interaction
        selectedForeground the selected glyphs that are changing during an interaction!

----- Method: MorphWorldView class>>fullColorWhenInactive (in category 'instance creation') -----
fullColorWhenInactive

        FullColorWhenInactive ifNil: [FullColorWhenInactive := true].
        ^ FullColorWhenInactive
!

----- Method: MorphWorldView class>>fullColorWhenInactive: (in category 'instance creation') -----
fullColorWhenInactive: fullColor
        "MorphWorldView fullColorWhenInactive: true"
        "If FullColorWhenInactive is true then WorldMorphViews will created inside StandardSystemViews that cache their contents in full-color when the window is inactive. If it is false, only a half-tone gray approximation of the colors will be cached to save space."

        FullColorWhenInactive := fullColor.

        "Retroactively convert all extant windows"
        ((fullColor ifTrue: [StandardSystemView] ifFalse: [ColorSystemView])
                allInstances select:
                        [:v | v subViews notNil and: [v subViews isEmpty not and: [v firstSubView isKindOf: MorphWorldView]]])
                do: [:v | v uncacheBits.
                        v controller toggleTwoTone]!

----- Method: MorphWorldView class>>openOn: (in category 'instance creation') -----
openOn: aMorphWorld
        "Open a view on the given WorldMorph."

        self openOn: aMorphWorld label: 'A Morphic World'.!

----- Method: MorphWorldView class>>openOn:label: (in category 'instance creation') -----
openOn: aWorldMorph label: aString
        "Open a view with the given label on the given WorldMorph."
        ^ self openOn: aWorldMorph label: aString model: (CautiousModel new initialExtent: aWorldMorph initialExtent)!

----- Method: MorphWorldView class>>openOn:label:cautionOnClose: (in category 'instance creation') -----
openOn: aWorldMorph label: aString cautionOnClose: aBoolean
        "Open a view with the given label on the given WorldMorph."
        | aModel |
        aModel := aBoolean
                ifTrue: [CautiousModel new]
                ifFalse: [WorldViewModel new].
        ^ self openOn: aWorldMorph label: aString model: (aModel initialExtent: aWorldMorph initialExtent)!

----- Method: MorphWorldView class>>openOn:label:extent: (in category 'instance creation') -----
openOn: aWorldMorph label: aString extent: aPoint
        "Open a view with the given label and extent on the given WorldMorph."

        ^ self openOn: aWorldMorph
                label: aString
                model: (CautiousModel new initialExtent: aPoint)
!

----- Method: MorphWorldView class>>openOn:label:model: (in category 'instance creation') -----
openOn: aWorldMorph label: aString model: aModel
        "Open a view with the given label on the given WorldMorph."

        | topView |
        topView := self fullColorWhenInactive
                                ifTrue: [topView := ColorSystemView new]
                                ifFalse: [topView := StandardSystemView new].
        topView
                model: aModel;
                label: aString;
                borderWidth: 1;
                addSubView: (self new model: aWorldMorph);
                backgroundColor: aWorldMorph color.
        "minimumSize: aWorldMorph extent + (2@2); " "add border width"
        topView controller open!

----- Method: MorphWorldView class>>openWorld (in category 'instance creation') -----
openWorld

        | w |
        (w := MVCWiWPasteUpMorph newWorldForProject: nil).
        w bounds: (0@0 extent: 400@300).
        self openOn: w
                label: 'A Morphic World'
                extent: w fullBounds extent + 2.
!

----- Method: MorphWorldView class>>openWorldWith:labelled: (in category 'instance creation') -----
openWorldWith: aMorph labelled: labelString

        | w |
        (w := MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: aMorph.
        w extent: aMorph fullBounds extent.
        w startSteppingSubmorphsOf: aMorph.
        self openOn: w
                label: labelString
                extent: w fullBounds extent + 2.
!

----- Method: MorphWorldView>>computeInsetDisplayBox (in category 'private') -----
computeInsetDisplayBox
        "This overrides the same method in View.  (It avoids using displayTransform: because it can return inaccurate results, causing a MorphWorldView's inset display box to creep inward when resized.)"

        ^superView insetDisplayBox insetBy: borderWidth!

----- Method: MorphWorldView>>deEmphasizeView (in category 'deEmphasizing') -----
deEmphasizeView
        "This window is becoming inactive."

        Cursor normal show.    "restore the normal cursor"
        model deEmphasizeViewMVC: self topView cacheBitsAsTwoTone.
!

----- Method: MorphWorldView>>defaultControllerClass (in category 'controller access') -----
defaultControllerClass

        ^ MorphWorldController!

----- Method: MorphWorldView>>displayView (in category 'displaying') -----
displayView
        "This method is called by the system when the top view is framed or moved."
        | topView |
        model viewBox: self insetDisplayBox.
        self updateSubWindowExtent.
        topView := self topView.
        (topView == ScheduledControllers scheduledControllers first view
                or: [topView cacheBitsAsTwoTone not])
                ifTrue: [model displayWorldSafely]
                ifFalse: [model displayWorldAsTwoTone].  "just restoring the screen"!

----- Method: MorphWorldView>>update: (in category 'updating') -----
update: symbol

        ^ symbol == #newColor
                ifTrue: [self topView backgroundColor: model color dominantColor; uncacheBits; display]
                ifFalse: [super update: symbol].
!

----- Method: MorphWorldView>>updateSubWindowExtent (in category 'as yet unclassified') -----
updateSubWindowExtent
        "If this MorphWorldView represents a single Morphic SystemWindow, then update that window to match the size of the WorldView."

        | numMorphs subWindow |
        numMorphs := model submorphs size.
        "(Allow for the existence of an extra NewHandleMorph (for resizing).)"
        (numMorphs = 0 or: [numMorphs > 2]) ifTrue: [^self].
        subWindow := model submorphs detect: [:ea | ea respondsTo: #label]
                                ifNone: [^self].
        superView label = subWindow label ifFalse: [^self].
        subWindow position: model position + (0 @ -16). "adjust for WiW changes"
        subWindow extent: model extent - (0 @ -16).
        subWindow isActive ifFalse: [subWindow activate]!

PasteUpMorph subclass: #WiWPasteUpMorph
        instanceVariableNames: 'parentWorld hostWindow pendingEvent displayChangeSignatureOnEntry'
        classVariableNames: 'Debug'
        poolDictionaries: ''
        category: 'MorphicWiW-Basic'!

!WiWPasteUpMorph commentStamp: '<historical>' prior: 0!
This subclass of PasteUpMorph provides special support for viewing of a world in an inner window (WorldWindow).!

WiWPasteUpMorph subclass: #MVCWiWPasteUpMorph
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicWiW-ST80'!

!MVCWiWPasteUpMorph commentStamp: '<historical>' prior: 0!
A subclass of WiWPasteUpMorph that supports Morphic worlds embedded in MVC Views.!

----- Method: MVCWiWPasteUpMorph>>becomeTheActiveWorldWith: (in category 'activation') -----
becomeTheActiveWorldWith: evt

        worldState canvas: nil. "safer to start from scratch"
        self installFlaps.

!

----- Method: MVCWiWPasteUpMorph>>invalidRect:from: (in category 'change reporting') -----
invalidRect: damageRect from: aMorph

        worldState ifNil: [^self].
        worldState recordDamagedRect: damageRect
!

----- Method: MVCWiWPasteUpMorph>>isWindowForModel: (in category 'testing') -----
isWindowForModel: aModel
        "Return true if the receiver acts as the window for the given model"
        ^aModel == self model!

----- Method: MVCWiWPasteUpMorph>>position: (in category 'geometry') -----
position: aPoint
        "Change the position of this morph and and all of its submorphs."

        | delta |
        delta := aPoint - bounds topLeft.
        (delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"
        self changed.
        self privateFullMoveBy: delta.
        self changed.
!

----- Method: MVCWiWPasteUpMorph>>project (in category 'project') -----
project
        ^ Project current!

----- Method: MVCWiWPasteUpMorph>>resetViewBox (in category 'geometry') -----
resetViewBox
        | c |
        (c := worldState canvas) isNil ifTrue: [^self resetViewBoxForReal].
        c form == Display ifFalse: [^self resetViewBoxForReal].
        c origin = (0 @ 0) ifFalse: [^self resetViewBoxForReal].
        c clipRect extent = self viewBox extent
                ifFalse: [^self resetViewBoxForReal]!

----- Method: MVCWiWPasteUpMorph>>resetViewBoxForReal (in category 'geometry') -----
resetViewBoxForReal

        self viewBox ifNil: [^self].
        worldState canvas: (
                (Display getCanvas)
                        copyOffset:  0@0
                        clipRect: self viewBox
        )!

----- Method: MVCWiWPasteUpMorph>>revertToParentWorldWithEvent: (in category 'activation') -----
revertToParentWorldWithEvent: evt

">>unused, but we may want some of this later
        self damageRecorder reset.
        World := parentWorld.
        World assuredCanvas.
        World installFlaps.
        owner changed.
        hostWindow setStripeColorsFrom: Color red.
        World restartWorldCycleWithEvent: evt.
<<<"

!

----- Method: MVCWiWPasteUpMorph>>viewBox: (in category 'project state') -----
viewBox: newViewBox
        | vb |
        worldState resetDamageRecorder. "since we may have moved, old data no longer valid"
        ((vb := self viewBox) isNil or: [vb ~= newViewBox])
                ifTrue: [worldState canvas: nil].
        worldState viewBox: newViewBox.
        self bounds: newViewBox. "works better here than simply storing into bounds"
        worldState assuredCanvas.
        "Paragraph problem workaround; clear selections to avoid screen droppings:"
        self flag: #arNote. "Probably unnecessary"
        worldState handsDo: [:h | h releaseKeyboardFocus].
        self fullRepaintNeeded!

----- Method: MVCWiWPasteUpMorph>>worldUnderCursor (in category 'as yet unclassified') -----
worldUnderCursor

        ^self!

----- Method: WiWPasteUpMorph class>>say: (in category 'as yet unclassified') -----
say: x

        (Debug ifNil: [Debug := OrderedCollection new])
                add: x asString,'
'.
        Debug size > 500 ifTrue: [Debug := Debug copyFrom: 200 to: Debug size]!

----- Method: WiWPasteUpMorph class>>show (in category 'as yet unclassified') -----
show

        Debug inspect.
        Debug := OrderedCollection new.!

----- Method: WiWPasteUpMorph>>becomeTheActiveWorldWith: (in category 'activation') -----
becomeTheActiveWorldWith: evt
        "Make the receiver become the active world, and give its hand the event provided, if not nil"

        | outerWorld |
        World == self ifTrue: [^ self].
        worldState resetDamageRecorder. "since we may have moved, old data no longer valid"
        hostWindow setStripeColorsFrom: Color green.
        worldState canvas: nil. "safer to start from scratch"
        displayChangeSignatureOnEntry := Display displayChangeSignature.

        "Messy stuff to clear flaps from outer world"
        Flaps globalFlapTabsIfAny do: [:f | f changed].
        outerWorld := World.
        World := self.
        self installFlaps.
        World := outerWorld.
        outerWorld displayWorld.
        World := self.

        self viewBox: hostWindow panelRect.
        self startSteppingSubmorphsOf: self.
        self changed.
        pendingEvent := nil.
        evt ifNotNil: [self primaryHand handleEvent: (evt setHand: self primaryHand)].

!

----- Method: WiWPasteUpMorph>>displayWorld (in category 'world state') -----
displayWorld

        "RAA 27 Nov 99 - if we are not active, then the parent should do the drawing"

        self flag: #bob. "probably not needed"

        World == self ifTrue: [^super displayWorld].
        parentWorld ifNotNil: [^parentWorld displayWorld].
        ^super displayWorld "in case MVC needs it"!

----- Method: WiWPasteUpMorph>>doDeferredUpdating (in category 'update cycle') -----
doDeferredUpdating
        "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature."

        PasteUpMorph disableDeferredUpdates ifTrue: [^ false].
        (Display deferUpdates: true) ifNil: [^ false].  "deferred updates not supported"

        self resetViewBox.
        ^ true
!

----- Method: WiWPasteUpMorph>>doOneCycle (in category 'world state') -----
doOneCycle

        pendingEvent ifNotNil: [
                self primaryHand handleEvent: (pendingEvent setHand: self primaryHand).
                pendingEvent := nil.
        ].
        ^super doOneCycle.!

----- Method: WiWPasteUpMorph>>extent: (in category 'geometry') -----
extent: x

        super extent: x.
        self resetViewBox.!

----- Method: WiWPasteUpMorph>>goBack (in category 'world state') -----
goBack
        "Return to the previous project.  For the moment, this is not allowed from inner worlds"

        self inform: 'Project changes are not yet allowed
from inner worlds.'!

----- Method: WiWPasteUpMorph>>hostWindow: (in category 'initialization') -----
hostWindow: x

        hostWindow := x.
        worldState canvas: nil. "safer to start from scratch"
        self viewBox: hostWindow panelRect.
!

----- Method: WiWPasteUpMorph>>initialize (in category 'initialization') -----
initialize

        super initialize.
        parentWorld := World.
!

----- Method: WiWPasteUpMorph>>jumpToProject (in category 'world state') -----
jumpToProject
        "Jump directly to another project.  However, this is not currently allowed for inner worlds"

        self inform: 'Project changes are not yet allowed
from inner worlds.'!

----- Method: WiWPasteUpMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt

        (World == self or: [World isNil]) ifTrue: [^ super mouseDown: evt].
        (self bounds containsPoint: evt cursorPoint) ifFalse: [^ self].

        self becomeTheActiveWorldWith: evt.
!

----- Method: WiWPasteUpMorph>>resetViewBox (in category 'geometry') -----
resetViewBox
        | c |
        (c := worldState canvas) isNil ifTrue: [^self resetViewBoxForReal].
        c form == Display ifFalse: [^self resetViewBoxForReal].
        c origin = (0 @ 0) ifFalse: [^self resetViewBoxForReal].
        c clipRect extent = (self viewBox intersect: parentWorld viewBox) extent
                ifFalse: [^self resetViewBoxForReal]!

----- Method: WiWPasteUpMorph>>resetViewBoxForReal (in category 'geometry') -----
resetViewBoxForReal

        | newClip |
        self viewBox ifNil: [^self].
        newClip := self viewBox intersect: parentWorld viewBox.
        worldState canvas: (
                Display getCanvas
                        copyOffset:  0@0
                        clipRect: newClip
        )!

----- Method: WiWPasteUpMorph>>restartWorldCycleWithEvent: (in category 'WiW support') -----
restartWorldCycleWithEvent: evt

        "redispatch that click in outer world"

        pendingEvent := evt.
        Project spawnNewProcessAndTerminateOld: true
!

----- Method: WiWPasteUpMorph>>restoreDisplay (in category 'world state') -----
restoreDisplay

        World ifNotNil:[World restoreMorphicDisplay]. "I don't actually expect this to be called"!

----- Method: WiWPasteUpMorph>>revertToParentWorldWithEvent: (in category 'activation') -----
revertToParentWorldWithEvent: evt

        "RAA 27 Nov 99 - if the display changed while we were in charge, parent may need to redraw"

        worldState resetDamageRecorder. "Terminate local display"
        World := parentWorld.
        World assuredCanvas.
        World installFlaps.
        hostWindow setStripeColorsFrom: Color red.
        (displayChangeSignatureOnEntry = Display displayChangeSignature) ifFalse: [
                World fullRepaintNeeded; displayWorld
        ].
        evt ifNotNil: [World restartWorldCycleWithEvent: evt].

!

----- Method: WiWPasteUpMorph>>validateMouseEvent: (in category 'WiW support') -----
validateMouseEvent: evt

        evt isMouseDown ifFalse: [^ self].

        "any click outside returns us to our home world"
        (self bounds containsPoint: evt cursorPoint) ifFalse: [
                self revertToParentWorldWithEvent: evt.
        ].!

----- Method: WiWPasteUpMorph>>viewBox: (in category 'project state') -----
viewBox: newViewBox
        | vb |
        worldState resetDamageRecorder. "since we may have moved, old data no longer valid"
        ((vb := self viewBox) isNil or: [vb ~= newViewBox])
                ifTrue: [worldState canvas: nil].
        worldState viewBox: newViewBox.
        bounds := newViewBox.
        worldState assuredCanvas.
        "Paragraph problem workaround; clear selections to avoid screen droppings:"
        self flag: #arNote. "Probably unnecessary"
        worldState handsDo: [:h | h releaseKeyboardFocus].
        self fullRepaintNeeded!

Object subclass: #WorldViewModel
        instanceVariableNames: 'initialExtent'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicWiW-ST80'!

!WorldViewModel commentStamp: '<historical>' prior: 0!
Serves as a model for a WorldView -- a morphic world viewed within an mvc project.!

WorldViewModel subclass: #CautiousModel
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'MorphicWiW-ST80'!

!CautiousModel commentStamp: '<historical>' prior: 0!
A model for a morphic world view which will ask for confirmation before being closed, unless the corresponding preference is set to false. !

----- Method: CautiousModel>>okToChange (in category 'updating') -----
okToChange
        Preferences cautionBeforeClosing ifFalse: [^ true].
        Sensor leftShiftDown ifTrue: [^ true].

        Beeper beep.
        ^ self confirm: 'Warning!!
If you answer "yes" here, this
window will disappear and
its contents will be lost!!
Do you really want to do that?'

"CautiousModel new okToChange"!

----- Method: WorldViewModel>>fullScreenSize (in category 'user interface') -----
fullScreenSize
        "Answer the size to which a window displaying the receiver should be set"

        ^ (0@0 extent: DisplayScreen actualScreenSize) copy!

----- Method: WorldViewModel>>initialExtent (in category 'user interface') -----
initialExtent
        initialExtent ifNotNil: [^ initialExtent].
        ^ super initialExtent!

----- Method: WorldViewModel>>initialExtent: (in category 'as yet unclassified') -----
initialExtent: anExtent
        initialExtent := anExtent!