" DCI program: BB2Shapes "

" Exported from Squeak 7179-basic.76.image on: 18 December 2011 by: Trygve "

" Data perspective "

" Class BB2Arrow "

" See comment in Window>>BB2Window

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.

"

LineMorph subclass: #BB2Arrow
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB2Shapes-Data'

" BB2Arrow instance methods in category: access "

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

" BB2Arrow instance methods in category: animation "

growFrom: startShape to: endShape
    | stepMax pt1 pt2 startPoint w |
    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].

" BB2Arrow instance methods in category: private "

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

wantsSteps
    ^false

" BB2Arrow class class methods in category: instance creation "

new
    ^self basicNew

" Class BB2Circle "

" Also see comment in Window>>BB2Window
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 ... "

CircleMorph subclass: #BB2Circle
    instanceVariableNames: 'window smallExtent bigExtent originalCenter'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB2Shapes-Data'

" BB2Circle instance methods in category: access "

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

center: cnt
    super center: cnt.
    originalCenter ifNotNil: [self center = originalCenter ifFalse: [self error: 'changed center']].

delete
    super delete.

window: w
    window := w.

" BB2Circle instance methods in category: animation "

displayLarge: label| t |
    ((t := self owner traceWindow traceLevel) > 2 and: [t<4])
    ifTrue:
        [self extent: bigExtent.
        self center: self originalCenter.
        self color: Color "green "cyan.
        label ifNotEmpty: [self addLabelNamed: label]].
    self owner traceWindow traceLevel < 4
    ifTrue:
        [self owner trace: self role: label].

displayNormal
    self removeAllMorphs.
    self extent: smallExtent.
    self center: self originalCenter.
    self color: self defaultColor.

flash
    | oldColor w |
    oldColor := self color.
    self color: Color cyan.
    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].

" BB2Circle instance methods in category: 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.

defaultColor
    ^Color lightBlue

handlesMouseDown: evt
    ^false

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

mouseDownPriority
    ^100

originalCenter
    ^originalCenter ifNil: [originalCenter := self bounds center] ifNotNil: [originalCenter]

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

" Class BB2Database "

" See comment in Window>>BB2Window

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.
"

Object subclass: #BB2Database
    instanceVariableNames: 'window shapes arrows pickedShapes'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB2Shapes-Data'

" BB2Database instance methods in category: data access "

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.
    "window trace: candidate asOop role: nil. "
    ^candidate

shapesCount
    ^shapes size

window
    ^window

" BB2Database instance methods in category: data definition "

addShape: aShape
    ^shapes add: aShape

deleteRandomShape
    | aShape |
    shapes ifNotEmpty:
        [aShape := shapes atRandom: Collection randomForPicking.
        shapes remove: aShape.
        aShape delete]

newArrow
    | newArrow |
    newArrow := BB2Arrow new initialize.
    arrows add: newArrow.
    ^newArrow

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

removeShape: aShape
    shapes remove: aShape.

" BB2Database instance methods in category: private "

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

window: win
    window := win.

" Class BB2Star "

" See comment in Window>>BB2Window

A BB2Star 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 ...
"

StarMorph subclass: #BB2Star
    instanceVariableNames: 'window smallExtent bigExtent originalCenter'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB2Shapes-Data'

" BB2Star instance methods in category: access "

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

center: cnt
    super center: cnt.
    originalCenter ifNotNil: [self center = originalCenter ifFalse: [self error: 'changed center']].

delete
    super delete.

window: w
    window := w.

" BB2Star instance methods in category: animation "

displayLarge: label
    | t |
    ((t := self owner traceWindow traceLevel) > 2 and: [t<4])
    ifTrue:
        [self extent: bigExtent.
        self center: self originalCenter.
        self color: Color cyan.
        label ifNotEmpty: [self addLabelNamed: label]].
    self owner traceWindow traceLevel < 4
    ifTrue:
        [self owner trace: self role: label].

displayNormal
    self removeAllMorphs.
    self extent: smallExtent.
    self center: self originalCenter.
    self color: self defaultColor.

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].

" BB2Star instance methods in category: 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.

defaultColor
    ^Color lightBlue

handlesMouseDown: evt
    ^false

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

mouseDownPriority
    ^100

originalCenter
    ^originalCenter ifNil: [originalCenter := self bounds center] ifNotNil: [originalCenter]

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

" Context perspective "

" Context: BB2ChaosCtx "

" Class BB2ChaosCtx "

" See comment in Window>>BB2Window "

BB1Context subclass: #BB2ChaosCtx
    instanceVariableNames: 'data oldMap'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB2Shapes-Context'

" BB2ChaosCtx instance methods in category: data access "

data: aData
    data := aData.

removeAllArrows
    data removeAllArrows.

" BB2ChaosCtx instance methods in category: data manipulation "

remap
    oldMap := oldMap ifNil: [self clearRoleMap] ifNotNil: [roleMap copy].
    super remap.

" BB2ChaosCtx instance methods in category: role binding "

Arrow
    ^data newArrow

CurrentContext
    ^self

Diagram
    ^data window

Receiver
    ^data anyShape

Sender
    | obj |
    ^(obj := oldMap at: #Receiver ifAbsent: [nil])
    ifNil: [data anyShape]
    ifNotNil: [obj]

" BB2ChaosCtx instance methods in category: triggers "

startChaosAnimationOn: domainData
    data := domainData.
    self runInteractionFromRoleNamed: #Diagram.

" BB2ChaosCtx class class methods in category: context diagram "

linkBreakPoints
    | dict |
    (dict := Dictionary new)
        yourself.
    ^dict.

rolePositions
    | dict |
    (dict := Dictionary new)
        at: #Arrow put: 185@140;
        at: #CurrentContext put: 310@10;
        at: #Sender put: 45@200;
        at: #Receiver put: 335@190;
        at: #Diagram put: 170@10;
        yourself.
    ^dict.

" BB2ChaosCtx class class methods in category: role structure "

roleStructure
    ^super roleStructure
    at: #Arrow put: #(#Sender #Diagram #Receiver );
    at: #CurrentContext put: #();
    at: #Sender put: #();
    at: #Receiver put: #();
    at: #Diagram put: #(#Arrow #CurrentContext );
        yourself.

No diagram

" Methodful Role Arrow "

grow
    Diagram addMorphBack: self.
"    Sender displayNormal.
    Receiver displayNormal. "

    self growFrom: Sender to: Receiver.

" Methodless Role CurrentContext "

" Methodful Role Diagram "

run
    Diagram animateChaos.

animateChaos
    | w |
    [self currentState == #CHAOS]
    whileTrue:
        [CurrentContext removeAllArrows.
        CurrentContext remap.
        Arrow grow.
        (w := self world) ifNotNil: [w doOneCycle].
        "(Delay forMilliseconds: 75) wait"].

" Methodless Role Receiver "

" Methodless Role Sender "


" Context: BB2RolesCtx "

" Class BB2RolesCtx "

" See comment in Window>>BB2Window "

BB1Context subclass: #BB2RolesCtx
    instanceVariableNames: 'data'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB2Shapes-Context'

" BB2RolesCtx instance methods in category: data access "

currentState
    ^self window currentState

data
    ^data

data: aData
    data := aData.

newArrow
    ^data newArrow

removeAllArrows
    data removeAllArrows.

window
    ^data window

world
    ^data window world

" BB2RolesCtx instance methods in category: role binding "

CurrentContext
    ^self

Shape1
    ^data anyShape

Shape2
    ^data anyShape

Shape3
    ^data anyShape

Shape4
    ^data anyShape

Shape5
    ^data anyShape

" BB2RolesCtx instance methods in category: triggers "

startRolesAnimationOn: aData
    data := aData.
    [self currentState == #ROLES]
    whileTrue:
        [self removeAllArrows.
        self runInteractionFromRoleNamed: #Shape1.
        ].

" BB2RolesCtx class class methods in category: context diagram "

linkBreakPoints
    | dict |
    (dict := Dictionary new)
        yourself.
    ^dict.

rolePositions
    | dict |
    (dict := Dictionary new)
        at: #Shape3 put: 310@20;
        at: #Shape1 put: 5@20;
        at: #Shape2 put: 155@20;
        at: #CurrentContext put: 275@180;
        at: #Shape5 put: 625@30;
        at: #Shape4 put: 465@20;
        yourself.
    ^dict.

" BB2RolesCtx class class methods in category: role structure "

roleStructure
    ^super roleStructure
    at: #Shape3 put: #(#CurrentContext #Shape4 );
    at: #Shape1 put: #(#Shape2 #CurrentContext );
    at: #Shape2 put: #(#CurrentContext #Shape3 );
    at: #CurrentContext put: #();
    at: #Shape5 put: #();
    at: #Shape4 put: #(#Shape5 #CurrentContext );
        yourself.

No diagram

" Methodful Role CurrentContext "

drawArrowFrom: role1 to: role2
    self window createNewArrow growFrom: role1 to: role2.

" Methodful Role Shape1 "

run
    Shape1 rolePlay1

rolePlay1
    self displayLarge: '1'.
    CurrentContext drawArrowFrom: self to: Shape2.
    Shape2 rolePlay2.

" Methodful Role Shape2 "

rolePlay2
    self displayLarge: '2'.
    CurrentContext drawArrowFrom: self to: Shape3.
    Shape3 rolePlay3.

" Methodful Role Shape3 "

rolePlay3
    self displayLarge: '3'.
    CurrentContext drawArrowFrom: self to: Shape4.
    Shape4 rolePlay4.

" Methodful Role Shape4 "

rolePlay4
    self displayLarge: '4'.
    CurrentContext drawArrowFrom: self to: Shape5.
    Shape5 rolePlay5.

" Methodful Role Shape5 "

rolePlay5
    self displayLarge: '5'.


" Context: BB2ShapesCtx "

" Class BB2ShapesCtx "

" See comment in Window>>BB2Window "

BB1Context subclass: #BB2ShapesCtx
    instanceVariableNames: 'data'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB2Shapes-Context'

" BB2ShapesCtx instance methods in category: accessing "

anyShape
    ^data anyShape

data: aData
    data := aData.

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

removeAllArrows
    data removeAllArrows.

removeShape
    ^data removeShape

removeShape: aShape
    ^data removeShape: aShape

shapesCount
    ^data shapesCount.

" BB2ShapesCtx instance methods in category: role binding "

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

CurrentContext
    ^self

ShapesAnimator
    ^data window

" BB2ShapesCtx instance methods in category: triggers "

startShapesAnimationOn: aData
    data := aData.
    self runInteractionFromRoleNamed: #ShapesAnimator.

" BB2ShapesCtx class class methods in category: context diagram "

linkBreakPoints
    | dict |
    (dict := Dictionary new)
        yourself.
    ^dict.

rolePositions
    | dict |
    (dict := Dictionary new)
        at: #CurrentContext put: 45@115;
        at: #AllShapes put: 245@120;
        at: #ShapesAnimator put: 135@25;
        yourself.
    ^dict.

" BB2ShapesCtx class class methods in category: role structure "

roleStructure
    ^super roleStructure
    at: #CurrentContext put: #();
    at: #AllShapes put: #();
    at: #ShapesAnimator put: #(#AllShapes #CurrentContext );
        yourself.

No diagram

" Methodless Role AllShapes "

" Methodless Role CurrentContext "

" Methodful Role ShapesAnimator "

addShape
    | newShape margin newCenter |
    newShape := (Collection randomForPicking next * 10) rounded odd
                                ifTrue: [CurrentContext newShape: BB2Star]
                                ifFalse: [CurrentContext newShape: BB2Circle].
    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.

run
    ShapesAnimator animateShapes.

animateShapes
    | w |
    CurrentContext removeAllArrows.
    [self currentState == #SHAPES]
        whileTrue:
            [CurrentContext remap.
            AllShapes size >= 25
                ifTrue: [ShapesAnimator deleteShape].
            AllShapes size <= 25
                ifTrue: [ShapesAnimator addShape].
            (w := self world)
                ifNotNil: [w doOneCycle]]

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


" Window perspective "

" Class BB2TraceHolder "

" Works like a Transcript for logging. "

Workspace subclass: #BB2TraceHolder
    instanceVariableNames: 'shapesWindow traceLevel textPane window'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB2Shapes-Window'

" BB2TraceHolder instance methods in category: accessing "

shapesWindow: w
    shapesWindow := w.

window
    ^window

" BB2TraceHolder instance methods in category: private "

initialize
    super initialize.
    contents := '' asText.

okToChange
    ^true

" BB2TraceHolder instance methods in category: tracing "

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

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

delete
    window delete.

trace: aText
    | w |
    self contents: self contents asText , String cr asText , aText.
    self
        changed: #appendEntry;
        changed: #contents.
"    (w := window world) ifNotNil: [w doOneCycle]."

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

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

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

windowIsClosing
    shapesWindow ifNotNil: [shapesWindow traceWindowClosed].

" BB2TraceHolder instance methods in category: triggers "

openLabel: labelString bounds: aRect
    " BB2TraceHolder 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

" BB2TraceHolder class class methods in category: instance creation "

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

" Class BB2Window "

" The BB2Shapes 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 perspective 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. (#BB2ShapesCtx)
    'animate roles' : Latest interaction animation with trace window. (BB2RolesCtx)
        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. (BB2ArrowsCtx)
    'animate chaos arrows' : Message passing with no apparent structure. (BB2ChaosCtx)
The 'movie' method creates a sequence of snapshots that can be assempled to a movie (by a separate program. PhotoShop?)
    
     "

PasteUpMorph subclass: #BB2Window
    instanceVariableNames: 'data currentState processSemaphore videoGIFs traceWindow'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'BB2Shapes-Window'

" BB2Window instance methods in category: accessing "

createNewArrow
    | arrow |
    arrow := data newArrow.
    self addMorphBack: arrow.
    ^arrow

currentState
    ^currentState

" BB2Window instance methods in category: 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. "

" BB2Window instance methods in category: private "

data
    ^data

handlesKeyboard: evt
    ^ true

handlesMouseDown: evt
    ^true

handlesMouseOver: evt
    ^ false

initialize
    super initialize.
    self bounds: (10@10 extent: 700@500).
    self borderWidth: 5.
    self color: Color lightBrown.
    self borderColor: Color black.
    (data := BB2Database new) window: self.
    "processSemaphore := Semaphore forMutualExclusion."
    currentState := #STOPPED.

keyStroke: evt
    "self traceRM: evt keyValue."
    (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: [self traceWindow 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: [self traceWindow traceLevel: 4].

open
    self initialize.
    self openInWorld.
    self startShapesAnimation.

removeAllArrows
    data removeAllArrows.

" BB2Window instance methods in category: tracing "

sendMessage: msg from: obj1 to: obj2
    self createNewArrow growFrom: obj1 to: obj2.
    obj2 perform: msg.

sendMessageFrom: obj1 to: obj2
    self createNewArrow growFrom: obj1 to: obj2.

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

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

traceWindowClosed
    traceWindow := nil.

" BB2Window instance methods in category: triggers "

babyInspect
    | inspCl |
    inspCl := Smalltalk at: #CInspectorSRE ifAbsent: [^ self inspect] .
    inspCl new openOn: self.

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

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.

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

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

startShapesAnimation
    currentState = #SHAPES ifTrue: [^self].
    currentState := #SHAPES.
    traceWindow ifNotNil: [traceWindow delete].
    BB2ShapesCtx new startShapesAnimationOn: data.
    currentState := #STOPPED.

stopAnimation
    currentState := #STOPPED.

yellowButtonActivity: shiftKeyState
    | aMenu |
    currentState = #STOPPED ifFalse: [currentState := nil. ^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

" BB2Window class class methods in category: class initialization "

initialize
    " BB2Window initialize "
    TheWorldMenu unregisterOpenCommand: 'BB2Shapes Animation'.
    TheWorldMenu
        registerOpenCommand:
            {'BB2Shapes animation'. {BB2Window. #open}. 'The Baby demo'}.

" BB2Window class class methods in category: instance creation "

open
    " BB2Window open "
    ^self new open