,

DCIprogram: #Shapes

" Exported from Squeak 7179-basic.226 last modified on 3 November 2014 by: Trygve"

Reader friendly version

projection: Context

Class: ShapesCtx

Context subclass: #ShapesCtx
    instanceVariableNames: 'data'
    category: 'Shapes-Context'

" See comment in Window>>Window "

instanceMethods: attributes-read

anyShape
    ^data anyShape

shapesCount
    ^data shapesCount.

instanceMethods: attributes-write

newShape: shapeClass
    | shape |
    shape := shapeClass isBehavior ifTrue: [shapeClass new initialize] ifFalse: [nil].
    shape ifNotNil: [data addShape: shape].
    ^shape

removeShape: aShape
    ^data removeShape: aShape

instanceMethods: operations

startShapesAnimationOn: aData
    data := aData.
    data initialize; removeAllArrows.
    self triggerInteractionFrom: #SHAPESANIMATOR with: #animateShapes andArgs: {}.

instanceMethods: role binding

ALLSHAPES
    ^data allShapes copy " copy, to protect against side effects. "

CONTEXT
    ^self

SHAPESANIMATOR
    ^data window


Interaction: ShapesCtx

No diagram

roleMethods: SHAPESANIMATOR

instanceMethods: role methods

animateShapes
    | w |
    [self currentState == #SHAPES]
        whileTrue:
            [CONTEXT remap.
            ALLSHAPES size >= 25
                ifTrue: [SHAPESANIMATOR deleteShape].
            ALLSHAPES size <= 25
                ifTrue: [SHAPESANIMATOR addShape].
            (w := self world) ifNotNil: [w doOneCycle]]

addShape
    | newShape margin newCenter |
    newShape := (Collection randomForPicking next * 10) rounded odd
                                ifTrue: [CONTEXT newShape: Star]
                                ifFalse: [CONTEXT newShape: Circle].
    margin := newShape extent .
[ newCenter :=
                (self bounds left + margin x to: self bounds right - margin x) atRandom
                @ (self bounds top + margin y to: self bounds bottom - margin y) atRandom.
        ALLSHAPES
            noneSatisfy:
                [:someShape | (someShape fullBounds expandBy: newShape extent)
                    containsPoint: newCenter]
                ] whileFalse.
    newShape center: newCenter.
    self addMorphBack: newShape.
    newShape flash.

deleteShape
    | shape |
    (shape := CONTEXT anyShape)
    ifNotNil:
        [CONTEXT removeShape: shape.
        shape delete].


Class: RolesCtx

Context subclass: #RolesCtx
    instanceVariableNames: 'data'
    category: 'Shapes-Context'

" See comment in Window>>Window "

instanceMethods: attributes-read

currentState
    ^self window currentState

data
    ^data

window
    ^data window

world
    ^data window world

instanceMethods: attributes-write

data: aData
    data := aData.

instanceMethods: operations

startRolesAnimationOn: aData
    data := aData.
    [self currentState == #ROLES]
    whileTrue:
        [data removeAllArrows.
        self triggerInteractionFrom: #SHAPE1 with: #shape1Play.
        (Delay forMilliseconds: 2000) wait.
        ].

instanceMethods: role binding

ARROW12
    ^data newArrow

ARROW23
    ^data newArrow

ARROW34
    ^data newArrow

ARROW45
    ^data newArrow

SHAPE1
    ^data anyShape

SHAPE2
    ^data anyShape

SHAPE3
    ^data anyShape

SHAPE4
    ^data anyShape

SHAPE5
    ^data anyShape

instanceMethods: private

zznewArrow
    ^data newArrow

zzremoveAllArrows
    data removeAllArrows.


Interaction: RolesCtx

No diagram

roleMethods: ARROW34

instanceMethods: role methods

play34
    self growFrom: SHAPE3 to: SHAPE4.
    SHAPE4 shape4Play.

roleMethods: ARROW45

instanceMethods: role methods

play45
    self growFrom: SHAPE4 to: SHAPE5.
    SHAPE5 shape5Play.

roleMethods: SHAPE5

instanceMethods: role methods

shape5Play
    self displayLarge: '5'.

roleMethods: ARROW12

instanceMethods: role methods

play12
    self growFrom: SHAPE1 to: SHAPE2.
    SHAPE2 shape2Play.

roleMethods: SHAPE2

instanceMethods: role methods

shape2Play
    self displayLarge: '2'.
    ARROW23 play23.

roleMethods: SHAPE4

instanceMethods: role methods

shape4Play
    self displayLarge: '4'.
    ARROW45 play45.

roleMethods: SHAPE1

instanceMethods: role methods

shape1Play
    self displayLarge: '1'.
    ARROW12 play12.

roleMethods: SHAPE3

instanceMethods: role methods

shape3Play
    self displayLarge: '3'.
    ARROW34 play34.

roleMethods: ARROW23

instanceMethods: role methods

play23
    self growFrom: SHAPE2 to: SHAPE3.
    SHAPE3 shape3Play.


Class: ChaosCtx

Context subclass: #ChaosCtx
    instanceVariableNames: 'data'
    category: 'Shapes-Context'

" See comment in Window>>Window "

instanceMethods: attributes-write

removeAllArrows
    data removeAllArrows.

instanceMethods: operations

startChaosAnimationOn: domainData
    data := domainData.
    self triggerInteractionFrom: #DIAGRAM with: #animateChaos andArgs: {}.

instanceMethods: role binding

ARROW
    ^data newArrow

CURRENTCONTEXT
    ^self

DIAGRAM
    ^data window

RECEIVER
    ^data anyShape

SENDER
    ^data anyShape


Interaction: ChaosCtx

No diagram

roleMethods: ARROW

instanceMethods: role methods

grow
    DIAGRAM addMorphBack: self.
    self growFrom: SENDER to: RECEIVER.

roleMethods: DIAGRAM

instanceMethods: role methods

animateChaos
    [self currentState == #CHAOS]
    whileTrue:
        [CURRENTCONTEXT removeAllArrows.
        CURRENTCONTEXT remap.
        ARROW grow.
        (Delay forMilliseconds: 75) wait].



projection: Data

Class: Arrow

LineMorph subclass: #Arrow
    instanceVariableNames: ''
    category: 'Shapes-Data'

" See comment in Window>>Window

An ETHDemo3ArrowMorph is visible on the screen as an arrow.

Instance Variables
    endMorph:        <ETHDemo3StarMorph> The shape at the tail end of the arrow.
    startMorph:        <ETHDemo3StarMorph> The shape at the head of the arrow.
    stepCounter:        <Integer> An arrow is drawn through several steps. The stepCounter counts down; the arrow is complete when stepCounter = 0.
    stepMax:        <Integer> The number of steps used to draw a complete arrow.

"

instanceMethods: initialize-release

initialize
    super initialize.
    self beStraightSegments vertices: {0@0. 0@0} color: Color red borderWidth: 5 borderColor: Color red.
    self makeForwardArrow.

instanceMethods: attributes-write

color: aColor
    super color: aColor.
    self borderColor: aColor.

instanceMethods: operations

growFrom: startShape to: endShape
    | stepMax pt1 pt2 startPoint w |
    owner addMorphBack: self.
    stepMax := 10.
    self makeForwardArrow.
    startPoint := (startShape attachPointFrom: endShape center) rounded.
    1 to: stepMax do:
        [:stepCounter |
        pt1 := startPoint.
        pt2 := (endShape attachPointFrom: pt1) rounded.
        self
            verticesAt: 1 put: pt1;
            verticesAt: 2 put: (pt1 + (pt2 - pt1 * stepCounter // stepMax)) rounded.
        (w := self world) ifNotNil: [w doOneCycle].
        (Delay forMilliseconds: 20) wait].

instanceMethods: I/O

wantsSteps
    ^false

classMethods: instance creation

new
    ^self basicNew

Class: Circle

CircleMorph subclass: #Circle
    instanceVariableNames: 'window smallExtent bigExtent'
    category: 'Shapes-Data'

" Also see comment in Window>>Window
Instance variables:
    
window The background playfield.
    
smallExtent Exent of unlabeled circle
    
bigExtent Extent of labeled circle
    
originalCenter The position of the circle, needed to avoid creeping inaccuracies when changing from small to big to small ... "

instanceMethods: initialize-release

initialize
    super initialize.
    bounds := 0 @ 0 extent: 20@20.
    smallExtent := self extent.
    bigExtent := smallExtent * 2.
    self color: Color lightBlue.

window: w
    window := w.

instanceMethods: attributes-read

attachPointFrom: aPoint
    " Answer a point on my periphery suitable as an arrow end point. "
    ^(self bounds intersectionWithLineSegmentFromCenterTo: aPoint) rounded

instanceMethods: operations

displayLarge: label
    | t w |
    self extent: bigExtent.
    self color: Color cyan.
    t := self owner traceWindow traceLevel.
    (t >= 3 and: [label notEmpty]) ifTrue: [self addLabelNamed: label].
    (t >0 and: [t<4]) ifTrue: [self owner trace: self role: label].
    (w := self owner world) ifNotNil: [w doOneCycle].

displayNormal
    self removeAllMorphs.
    self extent: smallExtent.
    self color: Color lightBlue.

flash
    | oldColor w |
    oldColor := self color.
    self color: Color yellow.
    self extent: bigExtent.
    (w := self world) ifNotNil: [w doOneCycle].
    (Delay forMilliseconds: 500) wait.
    self extent: smallExtent.
    self color: oldColor.
    (w := self world) ifNotNil: [w doOneCycle].

printOn: strm
    super printOn: strm.
    strm nextPut: $(; nextPutAll: self bounds origin printString; nextPut: $).

instanceMethods: I/O

handlesMouseDown: evt
    ^false

instanceMethods: private

addLabelNamed: label
    | labelMorph |
    labelMorph := self findA: StringMorph.
    labelMorph
    ifNil:
        [labelMorph := StringMorph
                        contents: label
                        font: (StrikeFont familyName: 'NewYork' size: 24)
                        emphasis: 1.
        self addMorphBack: labelMorph]
    ifNotNil:
        [labelMorph contents: labelMorph contents , '+' , label].
    labelMorph center: self center.

Class: Database

Object subclass: #Database
    instanceVariableNames: 'window shapes arrows pickedShapes'
    category: 'Shapes-Data'

" See comment in Window>>Window

An instance of this class holds a universe of objects.

Instance Variables
    arrows:        <OrderedCollection of ETHDemo3ArrowMorph> the head of an arrow train is at the end.
    shapes:        <Set of ETHDemo3StarMorph> | <ETHDemo3CircleMorph> All shapes currently visible.
"

instanceMethods: initialize-release

initialize
    super initialize.
    shapes := IdentitySet new.
    arrows := IdentitySet new.
    pickedShapes := OrderedCollection new.

window: win
    window := win.

instanceMethods: attributes-read

allShapes
    ^shapes

anyShape
    " pick a shape at random that does not have submorphs (i.e., label). "
    | candidate |
    [candidate := shapes atRandom: Collection randomForPicking.
    pickedShapes includes: candidate]
        whileTrue.
    pickedShapes add: candidate.
    ^candidate

shapesCount
    ^shapes size

window
    ^window

instanceMethods: operations

addShape: aShape
    ^shapes add: aShape

newArrow
    | newArrow |
    newArrow := Arrow new initialize.
    arrows add: newArrow.
    window addMorphBack: newArrow.
    ^newArrow

removeAllArrows
    arrows do: [:arr | arr delete].
    shapes do: [:shape | shape displayNormal].
    arrows := IdentitySet new.
    pickedShapes := IdentitySet new.

removeShape: aShape
    shapes remove: aShape.

Class: Star

StarMorph subclass: #Star
    instanceVariableNames: 'window smallExtent bigExtent'
    category: 'Shapes-Data'

" See comment in Window>>Window

A Star is visible on the screen as a star.

Instance Variables
    
window The background playfield.
    
smallExtent Exent of unlabeled star
    
bigExtent Extent of labeled star
    
originalCenter The position of the star, needed to avoid creeping inaccuracies when changing from small to big to small ...
"

instanceMethods: initialize-release

initialize
    super initialize.
    smallExtent := self extent.
    bigExtent := smallExtent * 2.
    self color: Color lightBlue.

window: w
    window := w.

instanceMethods: attributes-read

attachPointFrom: aPoint
    " Answer a point on my periphery suitable as an arrow end point. "
    ^((Rectangle center: self center extent: smallExtent)
            intersectionWithLineSegmentFromCenterTo: aPoint)
                rounded

instanceMethods: operations

displayLarge: label
    | t w |
    self extent: bigExtent.
    self color: Color cyan.
    t := self owner traceWindow traceLevel.
    (t >= 3 and: [label notEmpty]) ifTrue: [self addLabelNamed: label].
    (t > 0 and: [t < 4]) ifTrue: [self owner trace: self role: label].
    (w := self owner world) ifNotNil: [w doOneCycle].

displayNormal
    self removeAllMorphs.
    self extent: smallExtent.
    self color: Color lightBlue.

flash
    | oldColor w |
    oldColor := self color.
    self color: Color yellow.
    self extent: bigExtent.
    (w := self world) ifNotNil: [w doOneCycle].
    (Delay forMilliseconds: 500) wait.
    self extent: smallExtent.
    self color: oldColor.
    (w := self world) ifNotNil: [w doOneCycle].

printOn: strm
    super printOn: strm.
    strm nextPut: $(; nextPutAll: self bounds origin printString; nextPut: $).

instanceMethods: I/O

handlesMouseDown: evt
    ^false

instanceMethods: private

addLabelNamed: label
    | labelMorph |
    labelMorph := self findA: StringMorph.
    labelMorph
    ifNil:
        [labelMorph := StringMorph
                        contents: label
                        font: (StrikeFont familyName: 'NewYork' size: 24)
                        emphasis: 1.
        self addMorphBack: labelMorph]
    ifNotNil:
        [labelMorph contents: labelMorph contents , '+' , label].
    labelMorph center: self center.

projection: Window

Class: TraceHolder

Workspace subclass: #TraceHolder
    instanceVariableNames: 'shapesWindow traceLevel textPane window'
    category: 'Shapes-Window'

" Works like a Transcript for logging. "

instanceMethods: initialize-release

initialize
    super initialize.
    contents := '' asText.

openLabel: labelString bounds: aRect
    " TraceHolder openLabel: 'Trace window' bounds: (Rectangle fromUser) "
    window _ (SystemWindow labelled: labelString) model: self.
    textPane := PluggableTextMorph
                            on: self
                            text: #contents
                            accept: nil
                            readSelection: nil
                            menu: nil.
    textPane font: ((TextStyle named: 'BitstreamVeraSans') fontAt: 4). "Preferences standardCodeFont."
    self addDependent: textPane.
    window addMorph: textPane frame: (0@0 corner: 1@1).
    window bounds: aRect.
    window openAsIsIn: window currentWorld.
    ^self

instanceMethods: attributes-read

window
    ^window

characterLimit
    " How many chars to retain on screen"
    ^ 20000

traceLevel
    traceLevel ifNil: [traceLevel := 0].
    ^traceLevel

instanceMethods: attributes-write

shapesWindow: w
    shapesWindow := w.

instanceMethods: operations

trace: object role: label
    | strm w |
    strm := TextStream on: Text new.
    object
    ifNil:
        [self traceLevel > 0 ifTrue: [strm cr; nextPutAll: ' ']
        ]
    ifNotNil:
        [self traceLevel > 0
        ifTrue: [
            strm cr; nextPutAll: ('object ID= [' , (object asOop printPaddedWith: $0 to: 4) , ']') asText.
            self traceLevel > 1
            ifTrue:
                [strm tab; nextPutAll: ' class= ' asText; nextPutAll: object class name asString asText.
                (self traceLevel > 2 and: [label notNil])
                ifTrue:
                    [strm nextPutAll: ' ';tab; nextPutAll: ' Shape' asText allBold; nextPutAll: label asString asText allBold
                    ]
                        ].
            label = '5' ifTrue: [strm cr]
            ]
        ].
    self contents: self contents asText , strm contents.
    self
        changed: #contents;
        changed: #appendEntry.
    (w := textPane world) ifNotNil: [w doOneCycle].
    (Delay forMilliseconds: 500) wait

traceLevel: anInt
    traceLevel := anInt.
    traceLevel = 0 ifTrue: [self contents: ''].

cancel
    self contents: '' asText.
    self changed: #contents.

windowIsClosing
    shapesWindow ifNotNil: [shapesWindow traceWindowClosed].

delete
    window delete.

instanceMethods: private

okToChange
    ^true

classMethods: instance creation

openLabel: aString bounds: aRect
    ^self new openLabel: aString bounds: aRect

Class: Window

PasteUpMorph subclass: #Window
    instanceVariableNames: 'data currentState processSemaphore videoGIFs traceWindow'
    category: 'Shapes-Window'

" The Shapes example animates a system of interacting objects. The objects are shown as shapes on a colored background. Message passing is shown as an arrow that grows from the sender object to the receiver.

The Data projection specifies the shape classes (circle and star), the Arrow class, and a database that holds the current visible objects.

There is one Context for each system operation as given in parenthesis below.
The four system operations (Right-button menu commands) are:
    '
animate shapes': Illustrates object creation and removal. (#ShapesCtx)
    '
animate roles' : Latest interaction animation with trace window. (RolesCtx)
        Keyboard commands:
            left arrow: start this animation
            right arrow: stop this animation
            Numeric 0: No trace
            Numeric 1: Trace object IDs
            Numeric 2: Also trace class names
            Numeric 3: Also trace role names.
    '
animate ordered arrows' : The arrows animation without tracing. (ArrowsCtx)
    '
animate chaos arrows' : Message passing with no apparent structure. (ChaosCtx)
The 'movie' method creates a sequence of snapshots that can be assempled to a movie (by a separate program. PhotoShop?)
    
     "

instanceMethods: initialize-release

initialize
    super initialize.
    self bounds: (75@10 extent: 700@500).
    self borderWidth: 5.
    self color: Color lightBrown.
    self borderColor: Color black.
    (data := Database new) window: self.
    currentState := #STOPPED.

instanceMethods: attributes-read

currentState
    ^currentState

traceWindow
    traceWindow
        ifNil:
            [traceWindow := TraceHolder
                                    openLabel: 'Trace of message receivers'
                                    bounds:
                                        (Rectangle origin: 510@511 corner: 1000@715).
            traceWindow shapesWindow: self].
    ^traceWindow

instanceMethods: operations

exitDemo
    self stopAnimation.
    traceWindow ifNotNil: [traceWindow delete].
    self delete.

startChaosAnimation
    currentState = #CHAOS ifTrue: [^self].
    data removeAllArrows.
    currentState := #CHAOS.
    traceWindow ifNotNil: [traceWindow delete].
    ChaosCtx new startChaosAnimationOn: data.
    currentState := #STOPPED.

startRolesAnimation
    currentState = #ROLES ifTrue: [^self].
    currentState := #ROLES.
    data removeAllArrows.
    traceWindow ifNotNil: [traceWindow cancel; traceLevel: 0].
    RolesCtx new startRolesAnimationOn: data.
    currentState := #STOPPED.

startShapesAnimation
    | w |
    currentState = #SHAPES ifTrue: [^self].
    currentState := #SHAPES.
    traceWindow ifNotNil: [traceWindow delete].
    data initialize.
    self removeAllMorphs.
    (w := self world) ifNotNil: [w doOneCycle].
    ShapesCtx new startShapesAnimationOn: data.
    currentState := #STOPPED.

stopAnimation
    currentState := #STOPPED.

instanceMethods: operations-tracing

trace: objId role: rName
    self traceWindow trace: objId role: rName

traceWindowClosed
    traceWindow := nil.

instanceMethods: I/O

handlesKeyboard: evt
    ^ true

handlesMouseDown: evt
    ^true

handlesMouseOver: evt
    ^ false

keyStroke: evt
    (evt keyValue = 28) " left arrow " ifTrue: [^self stopAnimation].
    (evt keyValue = 27) " Escape " ifTrue: [^self stopAnimation].
    (evt keyValue = 29) " right arrow " ifTrue: [^self startRolesAnimation].
    (evt keyValue = 48) " 0 " ifTrue: [traceWindow ifNotNil: [traceWindow cancel; traceLevel: 0]].
    (evt keyValue = 49) " 1 " ifTrue: [self traceWindow traceLevel: 1].
    (evt keyValue = 50) " 2 " ifTrue: [self traceWindow traceLevel: 2].
    (evt keyValue = 51) " 3 " ifTrue: [self traceWindow traceLevel: 3].
    (evt keyValue = 52) " 4 " ifTrue: [traceWindow ifNotNil: [traceWindow cancel; traceLevel: 4]].

mouseDown: evt
    "Handle a mouse down event. The default response is to let my
    eventHandler, if any, handle it."

    evt yellowButtonPressed
        ifTrue: ["First check for option (menu) click"
            ^ self yellowButtonActivity: evt shiftPressed].
    self eventHandler
        ifNotNil: [self eventHandler mouseDown: evt fromMorph: self].
    self comeToFront.
    evt hand newKeyboardFocus: self.

yellowButtonActivity: shiftKeyState
    | aMenu |
    currentState = #STOPPED ifFalse: [currentState := #STOPPED. ^self].
    aMenu := (MenuMorph new defaultTarget: self) addTitle: self printString;
                 add: 'animate shapes' action: #startShapesAnimation;
                 add: 'animate roles' action: #startRolesAnimation;
                 add: 'animate chaos arrows' action: #startChaosAnimation;
                 addLine;
                 add: 'stop animation' action: #stopAnimation;
                 add: 'EXIT' action: #exitDemo.
    aMenu add: 'video' action: #createVideoFrames. " for collecting a sequence of stills. "
    aMenu popUpInWorld

instanceMethods: private

data
    ^data

open
    self initialize.
    self openInWorld.
    self startShapesAnimation.

removeAllArrows
    data removeAllArrows.

instanceMethods: private-movie

createVideoFrames
    videoGIFs := OrderedCollection new: 1000.
    self startStepping.

saveAsGIF
    | canvasForm printBounds |
    videoGIFs
        ifNil: [videoGIFs := OrderedCollection new: 1000].
    printBounds := self fullBounds.
    canvasForm := FormCanvas extent: printBounds extent depth: 8.
    canvasForm
        setOrigin: printBounds origin negated
        clipRect: (0 @ 0 extent: printBounds extent).
    canvasForm fillColor: self color.
    (self submorphs select: [:ea | ea visible])
        reverseDo: [:ea | ea fullDrawOn: canvasForm].
    videoGIFs addLast: canvasForm

saveGIFsToFiles
    | version dirName videoDirName |
    version := 0.
    [dirName := 'video-' , version asString.
    (FileDirectory default
        entryAt: dirName
        ifAbsent: []) notNil]
    whileTrue: [version := version + 1].
    FileDirectory default createDirectory: dirName.
    videoDirName := (FileDirectory default directoryNamed: dirName) fullName.
    1
        to: videoGIFs size
        do: [:frameNo | JPEGReadWriter2 putForm: (videoGIFs at: frameNo) form onFileNamed: videoDirName , '\frame '
                    , (frameNo printStringPadded: 3) , '.jpg']

step
    videoGIFs
        ifNil: [^ self stopStepping].
    videoGIFs size < 250
        ifTrue: [self saveAsGIF]
        ifFalse:
            [self stopStepping.
            self saveGIFsToFiles.
            self stopAnimation]

stepTime
    ^ 40 "100"

wantsSteps
    ^false " Change to true if you want to record video. "

classMethods: instance creation

open
    " Window open "
    ^self new open