DCIprogram: #Shapes
" Exported from Squeak 7179-basic.226 last modified on 3 November 2014 by: Trygve"
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
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
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
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