Smalltalk › Squeak › Squeak - Dev

[squeak-dev] The Trunk: MorphicExtras-Demo-edc.1.mcz

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

1 message

commits-2

[squeak-dev] The Trunk: MorphicExtras-Demo-edc.1.mcz

Edgar J. De Cleene uploaded a new version of MorphicExtras-Demo to project The Trunk:
http://source.squeak.org/trunk/MorphicExtras-Demo-edc.1.mcz

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

Name: MorphicExtras-Demo-edc.1
Author: edc
Time: 1 September 2009, 11:50:25 am
UUID: c33369bc-42c8-4ec8-a6eb-1f58c7b84559
Ancestors:

initializeFlapsQuads lacks proper store of Scripting flap, should be same as EToys 4.0 until EToys was safe unload / load

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

SystemOrganization addCategory: #'MorphicExtras-Demo'!

TransformationMorph subclass: #TransformationB2Morph
instanceVariableNames: 'worldBoundsToShow useRegularWarpBlt'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

!TransformationB2Morph commentStamp: '<historical>' prior: 0!
A transformation which:

- is content to let someone else decide my bounds (I do not try to minimally enclose my submorphs)
- can use bi-linear interpolation!

----- Method: TransformationB2Morph>>adjustAfter: (in category 'private') -----
adjustAfter: changeBlock

"same as super, but without reference position stuff"

changeBlock value.
self chooseSmoothing.
self layoutChanged.
owner ifNotNil: [owner invalidRect: bounds]
!

----- Method: TransformationB2Morph>>computeBounds (in category 'geometry') -----
computeBounds

"the transform bounds must remain under the control of the owner in this case"!

----- Method: TransformationB2Morph>>drawSubmorphsOn: (in category 'drawing') -----
drawSubmorphsOn: aCanvas

| r1 fullG r2 actualCanvas newClip where deferredMorphs case |
(self innerBounds intersects: aCanvas clipRect) ifFalse: [^self].
useRegularWarpBlt == true ifTrue: [
^aCanvas
transformBy: transform
clippingTo: ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) rounded
during: [:myCanvas |
submorphs reverseDo:[:m | myCanvas fullDrawMorph: m]
]
smoothing: smoothing
].
r1 := self innerBounds intersect: aCanvas clipRect.
r1 area = 0 ifTrue: [^self].
fullG := (transform localBoundsToGlobal: self firstSubmorph fullBounds) rounded.
r2 := r1 intersect: fullG.
r2 area = 0 ifTrue: [^self].
newClip := (r2 expandBy: 1) rounded intersect: self innerBounds rounded.
deferredMorphs := #().
aCanvas
transform2By: transform "#transformBy: for pure WarpBlt"
clippingTo: newClip
during: [:myCanvas |
self scale > 1.0 ifTrue: [
actualCanvas := MultiResolutionCanvas new initializeFrom: myCanvas.
actualCanvas deferredMorphs: (deferredMorphs := OrderedCollection new).
] ifFalse: [
actualCanvas := myCanvas.
].
submorphs reverseDo:[:m | actualCanvas fullDrawMorph: m].
]
smoothing: smoothing.

deferredMorphs do: [ :each |
where := each bounds: each fullBounds in: self.
case := 2.
case = 1 ifTrue: [where := where origin rounded extent: where extent rounded].
case = 2 ifTrue: [where := where rounded].
each drawHighResolutionOn: aCanvas in: where.
].

!

----- Method: TransformationB2Morph>>extent: (in category 'geometry') -----
extent: aPoint

| newExtent |

newExtent := aPoint truncated.
bounds extent = newExtent ifTrue: [^self].
bounds := bounds topLeft extent: newExtent.
"self recomputeExtent."

!

----- Method: TransformationB2Morph>>useRegularWarpBlt: (in category 'as yet unclassified') -----
useRegularWarpBlt: aBoolean

useRegularWarpBlt := aBoolean!

Morph subclass: #BouncingAtomsMorph
instanceVariableNames: 'damageReported infectionHistory transmitInfection recentTemperatures temperature'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

!BouncingAtomsMorph commentStamp: '<historical>' prior: 0!
This morph shows how an ideal gas simulation might work. When it gets step messages, it makes all its atom submorphs move along their velocity vectors, bouncing when they hit a wall. It also exercises the Morphic damage reporting and display architecture. Here are some things to try:

1. Resize this morph as the atoms bounce around.
2. In an inspector on this morph, evaluate "self addAtoms: 10."
3. Try setting quickRedraw to false in invalidRect:. This gives the
default damage reporting and incremental redraw. Try it for
100 atoms.
4. In the drawOn: method of AtomMorph, change drawAsRect to true.
5. Create a HeaterCoolerMorph and embed it in the simulation. Extract
it and use an inspector on it to evaluate "self velocityDelta: -5", then
re-embed it. Note the effect on atoms passing over it.
!

----- Method: BouncingAtomsMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'BouncingAtoms'
categories: #('Demo')
documentation: 'The original, intensively-optimized bouncing-atoms simulation by John Maloney'!

----- Method: BouncingAtomsMorph class>>initialize (in category 'class initialization') -----
initialize

self registerInFlapsRegistry. !

----- Method: BouncingAtomsMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(BouncingAtomsMorph new 'Bouncing Atoms' 'Atoms, mate')
forFlapNamed: 'Widgets']!

----- Method: BouncingAtomsMorph class>>unload (in category 'class initialization') -----
unload
"Unload the receiver from global registries"

self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] !

----- Method: BouncingAtomsMorph>>addAtoms: (in category 'other') -----
addAtoms: n
"Add a bunch of new atoms."

| a |
n timesRepeat: [
a := AtomMorph new.
a randomPositionIn: bounds maxVelocity: 10.
self addMorph: a].
self stopStepping.
!

----- Method: BouncingAtomsMorph>>addCustomMenuItems:hand: (in category 'menu') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph

super addCustomMenuItems: aCustomMenu hand: aHandMorph.
aCustomMenu add: 'startInfection' translated action: #startInfection.
aCustomMenu add: 'set atom count' translated action: #setAtomCount.
aCustomMenu add: 'show infection history' translated action: #showInfectionHistory:.
!

----- Method: BouncingAtomsMorph>>addMorphFront: (in category 'submorphs-add/remove') -----
addMorphFront: aMorph
"Called by the 'embed' meta action. We want non-atoms to go to the back."
"Note: A user would not be expected to write this method. However, a sufficiently advanced user (e.g, an e-toy author) might do something equivalent by overridding the drag-n-drop messages when they are implemented."

(aMorph isMemberOf: AtomMorph)
ifTrue: [super addMorphFront: aMorph]
ifFalse: [super addMorphBack: aMorph].!

----- Method: BouncingAtomsMorph>>areasRemainingToFill: (in category 'drawing') -----
areasRemainingToFill: aRectangle
color isTranslucent
ifTrue: [^ Array with: aRectangle]
ifFalse: [^ aRectangle areasOutside: self bounds]!

----- Method: BouncingAtomsMorph>>collisionPairs (in category 'other') -----
collisionPairs
"Return a list of pairs of colliding atoms, which are assumed to be
circles of known radius. This version uses the morph's positions--i.e.
the top-left of their bounds rectangles--rather than their centers."

| count sortedAtoms radius twoRadii radiiSquared collisions p1 continue j p2 distSquared m1 m2 |
count := submorphs size.
sortedAtoms := submorphs
asSortedCollection: [:mt1 :mt2 | mt1 position x < mt2 position x].
radius := 8.
twoRadii := 2 * radius.
radiiSquared := radius squared * 2.
collisions := OrderedCollection new.
1 to: count - 1
do:
[:i |
m1 := sortedAtoms at: i.
p1 := m1 position.
continue := (j := i + 1) <= count.
[continue] whileTrue:
[m2 := sortedAtoms at: j.
p2 := m2 position.
continue := p2 x - p1 x <= twoRadii
ifTrue:
[distSquared := (p1 x - p2 x) squared + (p1 y - p2 y) squared.
distSquared < radiiSquared
ifTrue: [collisions add: (Array with: m1 with: m2)].
(j := j + 1) <= count]
ifFalse: [false]]].
^collisions!

----- Method: BouncingAtomsMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color
r: 0.8
g: 1.0
b: 0.8!

----- Method: BouncingAtomsMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
"Clear the damageReported flag when redrawn."

super drawOn: aCanvas.
damageReported := false.!

----- Method: BouncingAtomsMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
damageReported := false.
self extent: 400 @ 250.

infectionHistory := OrderedCollection new.
transmitInfection := false.
self addAtoms: 30!

----- Method: BouncingAtomsMorph>>intoWorld: (in category 'initialization') -----
intoWorld: aWorld
"Make sure report damage at least once"
damageReported := false.
super intoWorld: aWorld.!

----- Method: BouncingAtomsMorph>>invalidRect:from: (in category 'change reporting') -----
invalidRect: damageRect from: aMorph
"Try setting 'quickRedraw' to true. This invalidates the entire morph, whose bounds typically subsume all it's submorphs. (However, this code checks that assumption and passes through any damage reports for out-of-bounds submorphs. Note that atoms with super-high velocities do occaisionally shoot through the walls!!) An additional optimization is to only submit only damage report per display cycle by using the damageReported flag, which is reset to false when the morph is drawn."

| quickRedraw |
quickRedraw := true. "false gives the original invalidRect: behavior"
(quickRedraw and:
[(bounds origin <= damageRect topLeft) and:
[damageRect bottomRight <= bounds corner]]) ifTrue: [
"can use quick redraw if damage is within my bounds"
damageReported ifFalse: [super invalidRect: bounds from: self]. "just report once"
damageReported := true.
] ifFalse: [super invalidRect: damageRect from: aMorph]. "ordinary damage report"!

----- Method: BouncingAtomsMorph>>setAtomCount (in category 'menu') -----
setAtomCount

| countString count |
countString := UIManager default
request: 'Number of atoms?'
initialAnswer: self submorphCount printString.
countString isEmpty ifTrue: [^ self].
count := Integer readFrom: (ReadStream on: countString).
self removeAllMorphs.
self addAtoms: count.
!

----- Method: BouncingAtomsMorph>>showInfectionHistory: (in category 'other') -----
showInfectionHistory: evt
"Place a graph of the infection history in the world."

| graph |
infectionHistory isEmpty ifTrue: [^ self].
graph := GraphMorph new data: infectionHistory.
graph extent: ((infectionHistory size + (2 * graph borderWidth) + 5)@(infectionHistory last max: 50)).
evt hand attachMorph: graph.
!

----- Method: BouncingAtomsMorph>>startInfection (in category 'menu') -----
startInfection

self submorphsDo: [:m | m infected: false].
self firstSubmorph infected: true.
infectionHistory := OrderedCollection new: 500.
transmitInfection := true.
self startStepping.
!

----- Method: BouncingAtomsMorph>>step (in category 'stepping and presenter') -----
step
"Bounce those atoms!!"

| r bounces |
super step.
bounces := 0.
r := bounds origin corner: (bounds corner - (8@8)).
self submorphsDo: [ :m |
(m isMemberOf: AtomMorph) ifTrue: [
(m bounceIn: r) ifTrue: [bounces := bounces + 1]]].
"compute a 'temperature' that is proportional to the number of bounces
divided by the circumference of the enclosing rectangle"
self updateTemperature: (10000.0 * bounces) / (r width + r height).
transmitInfection ifTrue: [self transmitInfection].
!

----- Method: BouncingAtomsMorph>>stepTime (in category 'testing') -----
stepTime
"As fast as possible."

^ 0
!

----- Method: BouncingAtomsMorph>>transmitInfection (in category 'other') -----
transmitInfection

| infected count |
self collisionPairs do: [:pair |
infected := false.
pair do: [:atom | atom infected ifTrue: [infected := true]].
infected
ifTrue: [pair do: [:atom | atom infected: true]]].

count := 0.
self submorphsDo: [:m | m infected ifTrue: [count := count + 1]].
infectionHistory addLast: count.
count = submorphs size ifTrue: [
transmitInfection := false.
self stopStepping].
!

----- Method: BouncingAtomsMorph>>updateTemperature: (in category 'other') -----
updateTemperature: currentTemperature
"Record the current temperature, which is taken to be the number of atoms that have bounced in the last cycle. To avoid too much jitter in the reading, the last several readings are averaged."

recentTemperatures isNil
ifTrue:
[recentTemperatures := OrderedCollection new.
20 timesRepeat: [recentTemperatures add: 0]].
recentTemperatures removeLast.
recentTemperatures addFirst: currentTemperature.
temperature := recentTemperatures sum asFloat / recentTemperatures size!

Morph subclass: #ScreeningMorph
instanceVariableNames: 'screenForm displayMode passingColor passElseBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

!ScreeningMorph commentStamp: '<historical>' prior: 0!
ScreeningMorph uses its first submorph as a screen, and its second submorph as a source. It also wants you to choose (when showing only the screen) the passing color in the screen. It then makes up a 1-bit mask which clips the source, and displays transparently outside it.!

----- Method: ScreeningMorph>>addCustomMenuItems:hand: (in category 'menu') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph
super addCustomMenuItems: aCustomMenu hand: aHandMorph.
submorphs isEmpty ifTrue:
[^ aCustomMenu add: '*Please add a source morph*' translated action: #itself].
submorphs size = 1 ifTrue:
[^ aCustomMenu add: '*Please add a screen morph*' translated action: #itself].
submorphs size > 2 ifTrue:
[^ aCustomMenu add: '*I have too many submorphs*' translated action: #itself].
aCustomMenu add: 'show screen only' translated action: #showScreenOnly.
aCustomMenu add: 'show source only' translated action: #showSourceOnly.
aCustomMenu add: 'show screen over source' translated action: #showScreenOverSource.
aCustomMenu add: 'show source screened' translated action: #showScreened.
aCustomMenu add: 'exchange source and screen' translated action: #exchange.
displayMode == #showScreenOnly ifTrue:
[aCustomMenu add: 'choose passing color' translated action: #choosePassingColor.
aCustomMenu add: 'choose blocking color' translated action: #chooseBlockingColor].
!

----- Method: ScreeningMorph>>addMorph: (in category 'submorphs-add/remove') -----
addMorph: aMorph

| f |
super addMorph: aMorph.
submorphs size <= 2 ifTrue:
[self bounds: submorphs last bounds].
submorphs size = 2 ifTrue:
["The screenMorph has just been added.
Choose as the passingColor the center color of that morph"
f := self screenMorph imageForm.
passingColor := f colorAt: f boundingBox center.
passElseBlock := true]!

----- Method: ScreeningMorph>>chooseBlockingColor (in category 'menu') -----
chooseBlockingColor
passingColor := Color fromUser.
passElseBlock := false.
self layoutChanged!

----- Method: ScreeningMorph>>choosePassingColor (in category 'menu') -----
choosePassingColor
passingColor := Color fromUser.
passElseBlock := true.
self layoutChanged!

----- Method: ScreeningMorph>>containsPoint: (in category 'geometry testing') -----
containsPoint: aPoint
submorphs size = 2 ifFalse: [^ super containsPoint: aPoint].
^ self screenMorph containsPoint: aPoint!

----- Method: ScreeningMorph>>exchange (in category 'menu') -----
exchange
submorphs swap: 1 with: 2.
self changed!

----- Method: ScreeningMorph>>fullDrawOn: (in category 'drawing') -----
fullDrawOn: aCanvas
| mergeForm |
submorphs isEmpty ifTrue: [^super fullDrawOn: aCanvas].
(aCanvas isVisible: self fullBounds) ifFalse: [^self].
(submorphs size = 1 or: [displayMode == #showScreenOnly])
ifTrue: [^aCanvas fullDrawMorph: self screenMorph].
displayMode == #showSourceOnly
ifTrue: [^aCanvas fullDrawMorph: self sourceMorph].
displayMode == #showScreenOverSource
ifTrue:
[aCanvas fullDrawMorph: self sourceMorph.
^aCanvas fullDrawMorph: self screenMorph].
displayMode == #showScreened
ifTrue:
[aCanvas fullDrawMorph: self screenMorph.
self flag: #fixCanvas. "There should be a more general way than this"
mergeForm := self sourceMorph
imageFormForRectangle: self screenMorph bounds.
(BitBlt current toForm: mergeForm)
copyForm: self screenForm
to: 0 @ 0
rule: Form and
colorMap: (Bitmap with: 0 with: 4294967295).
aCanvas paintImage: mergeForm at: self screenMorph position]!

----- Method: ScreeningMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
passingColor := Color black.
passElseBlock := true.
displayMode := #showScreened.
self enableDragNDrop!

----- Method: ScreeningMorph>>layoutChanged (in category 'layout') -----
layoutChanged

screenForm := nil.
submorphs size >= 2
ifTrue: [self disableDragNDrop]
ifFalse: [self enableDragNDrop].
submorphs size = 2 ifTrue:
[bounds := ((self sourceMorph bounds merge: self screenMorph bounds) expandBy: 4)].
^ super layoutChanged!

----- Method: ScreeningMorph>>passElseBlock: (in category 'accessing') -----
passElseBlock: aBool
passElseBlock := aBool.!

----- Method: ScreeningMorph>>passingColor: (in category 'accessing') -----
passingColor: aColor
passingColor := aColor.!

----- Method: ScreeningMorph>>removedMorph: (in category 'private') -----
removedMorph: aMorph

submorphs size = 1 ifTrue:
[self bounds: submorphs first bounds].
super removedMorph: aMorph.!

----- Method: ScreeningMorph>>screenForm (in category 'private') -----
screenForm
| screenImage colorMap pickValue elseValue |
screenForm ifNotNil: [^screenForm].
passElseBlock ifNil: [passElseBlock := true].
passingColor ifNil: [passingColor := Color black].
elseValue := passElseBlock
ifTrue:
[pickValue := 4294967295.
0]
ifFalse:
[pickValue := 0.
4294967295].
screenImage := self screenMorph
imageFormForRectangle: self screenMorph bounds.
colorMap := screenImage newColorMap atAllPut: elseValue.
colorMap at: (passingColor indexInMap: colorMap) put: pickValue.
screenForm := Form extent: screenImage extent.
screenForm
copyBits: screenForm boundingBox
from: screenImage
at: 0 @ 0
colorMap: colorMap.
^screenForm!

----- Method: ScreeningMorph>>screenMorph (in category 'private') -----
screenMorph
^submorphs first!

----- Method: ScreeningMorph>>showScreenOnly (in category 'menu') -----
showScreenOnly
displayMode := #showScreenOnly.
self changed!

----- Method: ScreeningMorph>>showScreenOverSource (in category 'menu') -----
showScreenOverSource
displayMode := #showScreenOverSource.
self changed!

----- Method: ScreeningMorph>>showScreened (in category 'menu') -----
showScreened
displayMode := #showScreened.
self changed!

----- Method: ScreeningMorph>>showSourceOnly (in category 'menu') -----
showSourceOnly
displayMode := #showSourceOnly.
self changed!

----- Method: ScreeningMorph>>sourceMorph (in category 'private') -----
sourceMorph
^submorphs second!

----- Method: ScreeningMorph>>wantsRecolorHandle (in category 'e-toy support') -----
wantsRecolorHandle
"Answer whether the receiver would like a recolor handle to be
put up for it. We'd want to disable this but for the moment
that would cut off access to the button part of the properties
sheet. So this remains a loose end."
^ false!

RectangleMorph subclass: #AbstractMediaEventMorph
instanceVariableNames: 'startTimeInScore endTimeInScore'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

!AbstractMediaEventMorph commentStamp: '<historical>' prior: 0!
An abstract representation of media events to be placed in a PianoRollScoreMorph (or others as they are developed)!

----- Method: AbstractMediaEventMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 1!

----- Method: AbstractMediaEventMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color paleYellow!

----- Method: AbstractMediaEventMorph>>endTime (in category 'as yet unclassified') -----
endTime

^endTimeInScore ifNil: [startTimeInScore + 100]!

----- Method: AbstractMediaEventMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self layoutPolicy: TableLayout new;
listDirection: #leftToRight;
wrapCentering: #topLeft;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
layoutInset: 2;
rubberBandCells: true!

AbstractMediaEventMorph subclass: #ZASMCameraMarkMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

----- Method: ZASMCameraMarkMorph>>addCustomMenuItems:hand: (in category 'menu') -----
addCustomMenuItems: aMenu hand: aHandMorph
"Add custom halo menu items"

aMenu add: 'Go to this mark' translated target: self action: #gotoMark.
aMenu add: 'Set transition' translated target: self action: #setTransition.

super addCustomMenuItems: aMenu hand: aHandMorph
!

----- Method: ZASMCameraMarkMorph>>cameraController (in category 'as yet unclassified') -----
cameraController

^(self valueOfProperty: #cameraController)!

----- Method: ZASMCameraMarkMorph>>cameraPoint:cameraScale:controller: (in category 'as yet unclassified') -----
cameraPoint: aPoint cameraScale: aNumber controller: aController

self setProperty: #cameraPoint toValue: aPoint.
self setProperty: #cameraScale toValue: aNumber.
self setProperty: #cameraController toValue: aController.
self addMorph: (
StringMorph contents: aPoint printString,' ',(aNumber roundTo: 0.001) printString
) lock.!

----- Method: ZASMCameraMarkMorph>>cameraPoint:cameraScale:controller:page: (in category 'as yet unclassified') -----
cameraPoint: aPoint cameraScale: aNumber controller: aController page: aBookPage

self setProperty: #cameraPoint toValue: aPoint.
self setProperty: #cameraScale toValue: aNumber.
self setProperty: #cameraController toValue: aController.
self setProperty: #bookPage toValue: aBookPage.
self addMorphBack: (ImageMorph new image: (aBookPage imageForm scaledToSize: 80@80)) lock.
self setBalloonText: aPoint rounded printString,' ',(aNumber roundTo: 0.001) printString!

----- Method: ZASMCameraMarkMorph>>gotoMark (in category 'as yet unclassified') -----
gotoMark

self cameraController
turnToPage: (self valueOfProperty: #bookPage)
position: (self valueOfProperty: #cameraPoint)
scale: (self valueOfProperty: #cameraScale)
transition: (self valueOfProperty: #transitionSpec).
self setCameraValues.

!

----- Method: ZASMCameraMarkMorph>>handlesMouseDown: (in category 'event handling') -----
handlesMouseDown: evt

^true
!

----- Method: ZASMCameraMarkMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: newOwner event: anEvent

| holder |

newOwner isWorldMorph ifTrue: [
holder := ZASMScriptMorph new.
holder
position: self position;
setProperty: #cameraController toValue: self cameraController.
self world addMorph: holder.
holder addMorph: self.
holder startStepping.
].
super justDroppedInto: newOwner event: anEvent!

----- Method: ZASMCameraMarkMorph>>menuPageVisualFor:event: (in category 'as yet unclassified') -----
menuPageVisualFor: target event: evt

| tSpec menu subMenu directionChoices |

tSpec := self
valueOfProperty: #transitionSpec
ifAbsent: [
(self valueOfProperty: #bookPage)
valueOfProperty: #transitionSpec
ifAbsent: [{ 'silence' . #none. #none}]
].
menu := (MenuMorph entitled: 'Choose an effect
(it is now ' , tSpec second , ')') defaultTarget: self.
TransitionMorph allEffects do: [:effect |
directionChoices := TransitionMorph directionsForEffect: effect.
directionChoices isEmpty
ifTrue: [menu add: effect target: self
selector: #setProperty:toValue:
argumentList: (Array with: #transitionSpec
with: (Array with: tSpec first with: effect with: #none))]
ifFalse: [subMenu := MenuMorph new.
directionChoices do:
[:dir |
subMenu add: dir target: self
selector: #setProperty:toValue:
argumentList: (Array with: #transitionSpec
with: (Array with: tSpec first with: effect with: dir))].
menu add: effect subMenu: subMenu]].

menu popUpEvent: evt in: self world!

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

evt shiftPressed ifTrue: [^self].
self isSticky ifTrue: [^self].
evt hand grabMorph: self.!

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

evt shiftPressed ifTrue: [^self gotoMark].
!

----- Method: ZASMCameraMarkMorph>>setCameraValues (in category 'as yet unclassified') -----
setCameraValues

| camera |
camera := self cameraController.

"ick... since one may fail to fully take due to constraints, retry"
2 timesRepeat: [
camera cameraPoint: (self valueOfProperty: #cameraPoint).
camera cameraScale: (self valueOfProperty: #cameraScale).
].

!

----- Method: ZASMCameraMarkMorph>>setTransition (in category 'menu') -----
setTransition
"Set the transition"

^ self setTransition: ActiveEvent!

----- Method: ZASMCameraMarkMorph>>setTransition: (in category 'as yet unclassified') -----
setTransition: evt

| tSpec menu subMenu directionChoices |

tSpec := self
valueOfProperty: #transitionSpec
ifAbsent: [
(self valueOfProperty: #bookPage)
valueOfProperty: #transitionSpec
ifAbsent: [{ 'silence' . #none. #none}]
].
menu := (MenuMorph entitled: 'Choose an effect
(it is now ' , tSpec second , ')') defaultTarget: self.
TransitionMorph allEffects do: [:effect |
directionChoices := TransitionMorph directionsForEffect: effect.
directionChoices isEmpty
ifTrue: [menu add: effect target: self
selector: #setProperty:toValue:
argumentList: (Array with: #transitionSpec
with: (Array with: tSpec first with: effect with: #none))]
ifFalse: [subMenu := MenuMorph new.
directionChoices do:
[:dir |
subMenu add: dir target: self
selector: #setProperty:toValue:
argumentList: (Array with: #transitionSpec
with: (Array with: tSpec first with: effect with: dir))].
menu add: effect subMenu: subMenu]].

menu popUpEvent: evt in: self world!

----- Method: ZASMCameraMarkMorph>>veryDeepCopyWith: (in category 'copying') -----
veryDeepCopyWith: deepCopier
| camera page |
"Keep the same camera???"

(camera := self cameraController) ifNotNil: [
(deepCopier references includesKey: camera) ifFalse: [
"not recorded, outside our tree, use same camera"
deepCopier references at: camera put: camera]].
(page := self valueOfProperty: #bookPage) ifNotNil: [
(deepCopier references includesKey: page) ifFalse: [
deepCopier references at: page put: page]].

^ super veryDeepCopyWith: deepCopier

!

RectangleMorph subclass: #StickyPadMorph
instanceVariableNames: ''
classVariableNames: 'Colors LastColorIndex'
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

!StickyPadMorph commentStamp: 'sw 3/3/2004 13:31' prior: 0!
A custom item for the Squeakland Supplies bin, as defined by Kim Rose and BJ Con.A parts bin will deliver up translucent, borderless Rectangles in a sequence of 6 colors. It offers some complication to the parts-bin protocols in two ways::
* The multi-colored icon seen in the parts bin is not a thumbnail of any actual instance, all of which are monochrome
* New instances need to be given default names that are not the same as the name seen in the parts bin.!

----- Method: StickyPadMorph class>>defaultNameStemForInstances (in category 'parts bin') -----
defaultNameStemForInstances
"Answer the default name stem to use"

^ 'tear off'!

----- Method: StickyPadMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
"Answer a description of the receiver for use in a parts bin"

^ self partName: 'Sticky Pad'
categories: #('Graphics')
documentation: 'A translucent, borderless rectangle of a standard size, delivered in a predictable sequence of pastel colors'
sampleImageForm: (Form extent: 50@40 depth: 16
fromArray: #( 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461414680 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461414680 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1796762392 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461409563 1461414680 1796762392 1796762392 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1723098804 1723098804 1723098804 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521903284 1723098804 1723098804 1723096921 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1723098804 1723098804 1723098804 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521903284 1723098804 1723098804 1723096921 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1723098804 1723098804 1723098804 1599692633 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1521900214 1521900214 1521900214 1521903284 1723098804 1723098804 1723096921 1599692633 1599692633 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322274512 1322274512 1389318863 1389318863 1389318863 1328697138 1328697138 1328697138 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322274512 1322275535 1389318863 1389318863 1389317938 1328697138 1328697138 1328702226 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322274512 1389318863 1389318863 1389318863 1328697138 1328697138 1328697138 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1322275535 1389318863 1389318863 1389317938 1328697138 1328697138 1328702226 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322274512 1389318863 1389318863 1389318863 1328697138 1328697138 1328697138 1662149394 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1322275535 1389318863 1389318863 1389317938 1328697138 1328697138 1328702226 1662149394 1662149394 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521900214 1389318863 1389318863 1389318863 1460426508 1460426508 1460426508 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1521903284 1389318863 1389318863 1389317938 1460426508 1460426508 1460429548 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521900214 1723098804 1389318863 1389318863 1328697138 1460426508 1460426508 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1521903284 1723098804 1389318863 1389317938 1328697138 1460426508 1460429548 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521900214 1723098804 1723098804 1389318863 1328697138 1328697138 1460426508 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1521903284 1723098804 1723098804 1389317938 1328697138 1328697138 1460429548 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461409563 1723098804 1723098804 1723098804 1328697138 1328697138 1328697138 1659658988 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1461414680 1723098804 1723098804 1723096921 1328697138 1328697138 1328702226 1659658988 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461409563 1796762392 1723098804 1723098804 1599692633 1328697138 1328697138 1662149394 1659658988 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1461414680 1796762392 1723098804 1723096921 1599692633 1328697138 1328702226 1662149394 1659658988 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461409563 1796762392 1796762392 1723098804 1599692633 1599692633 1328697138 1662149394 1662149394 1659658988 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1736271741 1461414680 1796762392 1796762392 1723096921 1599692633 1599692633 1328702226 1662149394 1662149394 1659660157 1736271741 1736271741 1736271741 1736271741 1736271741)
offset: 0@0)!

----- Method: StickyPadMorph class>>initialize (in category 'class initialization') -----
initialize
"Class initialization"

LastColorIndex := 0.
Colors := {
TranslucentColor r: 0.0 g: 0.0 b: 0.839 alpha: 0.267.
TranslucentColor r: 0.484 g: 1.0 b: 0.452 alpha: 0.706.
TranslucentColor r: 1.0 g: 0.355 b: 0.71 alpha: 0.569.
TranslucentColor r: 1.0 g: 1.0 b: 0.03 alpha: 0.561.
TranslucentColor r: 0.484 g: 0.161 b: 1.0 alpha: 0.529.
TranslucentColor r: 0.097 g: 0.097 b: 0.097 alpha: 0.192.
}.

self registerInFlapsRegistry.

"StickyPadMorph initialize"!

----- Method: StickyPadMorph class>>launchPartVia:label: (in category 'parts bin') -----
launchPartVia: aSelector label: aString
"Obtain a morph by sending aSelector to self, and attach it to the morphic hand. This provides a general protocol for parts bins. Overridden here so that all instances will be given the name, unlike the prevailing convention for other object types"

| aMorph |
aMorph := self perform: aSelector.
aMorph setNameTo: self defaultNameStemForInstances. "i.e., circumvent uniqueness in this case"
aMorph setProperty: #beFullyVisibleAfterDrop toValue: true.
aMorph openInHand!

----- Method: StickyPadMorph class>>registerInFlapsRegistry (in category 'as yet unclassified') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"

self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(StickyPadMorph newStandAlone 'Sticky Pad' 'Each time you obtain one of these pastel, translucent, borderless rectangles, it will be a different color from the previous time.')
forFlapNamed: 'Supplies'.
cl registerQuad: #(StickyPadMorph newStandAlone 'Sticky Pad' 'Each time you obtain one of these pastel, translucent, borderless rectangles, it will be a different color from the previous time.')
forFlapNamed: 'PlugIn Supplies'.]!

----- Method: StickyPadMorph>>canHaveFillStyles (in category 'visual properties') -----
canHaveFillStyles
"Return true if the receiver can have general fill styles; not just
colors. This method is for gradually converting old morphs."
^ true!

----- Method: StickyPadMorph>>initializeToStandAlone (in category 'parts bin') -----
initializeToStandAlone
"Initialize the receiver to stand alone. Use the next color in the standard sequence."

Colors ifNil: [self initialize].
LastColorIndex :=
LastColorIndex
ifNil:
[1]
ifNotNil:
[(LastColorIndex \\ Colors size) + 1].
super initializeToStandAlone.
self assureExternalName.
self color: (Colors at: LastColorIndex).
self extent: 100@80.
self borderWidth: 0
!

RectangleMorph subclass: #ZoomAndScrollControllerMorph
instanceVariableNames: 'mouseDownPoint mouseMovePoint panAndTiltFactor zoomFactor target hasFocus currentKeyDown upDownCodes changeKeysState programmedMoves'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

----- Method: ZoomAndScrollControllerMorph>>addCustomMenuItems:hand: (in category 'menus') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph

super addCustomMenuItems: aCustomMenu hand: aHandMorph.
aCustomMenu addLine.
aCustomMenu add: 'change tilt and zoom keys' translated action: #changeKeys.
aCustomMenu add: 'run an existing camera script' translated action: #runAScript.
aCustomMenu add: 'edit an existing camera script' translated action: #editAScript.

!

----- Method: ZoomAndScrollControllerMorph>>cameraPoint (in category 'as yet unclassified') -----
cameraPoint

target ifNil: [^0@0].
^target cameraPoint
!

----- Method: ZoomAndScrollControllerMorph>>cameraPoint: (in category 'as yet unclassified') -----
cameraPoint: aPoint

target ifNil: [^self].
target cameraPoint: aPoint!

----- Method: ZoomAndScrollControllerMorph>>cameraPointRounded (in category 'as yet unclassified') -----
cameraPointRounded

^self cameraPoint rounded!

----- Method: ZoomAndScrollControllerMorph>>cameraScale (in category 'as yet unclassified') -----
cameraScale

target ifNil: [^1.0].
^target scale
!

----- Method: ZoomAndScrollControllerMorph>>cameraScale: (in category 'as yet unclassified') -----
cameraScale: aNumber

target ifNil: [^self].
target changeScaleTo: aNumber!

----- Method: ZoomAndScrollControllerMorph>>changeKeys (in category 'as yet unclassified') -----
changeKeys

upDownCodes := Dictionary new.
changeKeysState := #(up down in out).
self changed.!

----- Method: ZoomAndScrollControllerMorph>>currentCameraVersion (in category 'as yet unclassified') -----
currentCameraVersion

^2!

----- Method: ZoomAndScrollControllerMorph>>deadZoneWidth (in category 'as yet unclassified') -----
deadZoneWidth

^8
!

----- Method: ZoomAndScrollControllerMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ Color transparent!

----- Method: ZoomAndScrollControllerMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 0!

----- Method: ZoomAndScrollControllerMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightBlue!

----- Method: ZoomAndScrollControllerMorph>>doProgrammedMoves (in category 'as yet unclassified') -----
doProgrammedMoves

| thisMove startPoint endPoint startZoom endZoom newScale newPoint fractionLeft |

programmedMoves isEmptyOrNil ifTrue: [
^programmedMoves := nil
].
thisMove := programmedMoves first.
thisMove at: #pauseTime ifPresent: [ :ignore | ^self].

fractionLeft := self fractionLeftInMove: thisMove.
fractionLeft ifNil: [^programmedMoves := programmedMoves allButFirst].

startPoint := thisMove at: #startPoint ifAbsentPut: [self cameraPoint].
endPoint := thisMove at: #endPoint ifAbsentPut: [self cameraPoint].

startZoom := thisMove at: #startZoom ifAbsentPut: [self cameraScale].
endZoom := thisMove at: #endZoom ifAbsentPut: [self cameraScale].
newScale := endZoom - (endZoom - startZoom * fractionLeft).
newPoint := (endPoint - (endPoint - startPoint * fractionLeft)) "rounded".
target changeScaleTo: newScale.
target cameraPoint: newPoint.

fractionLeft <= 0 ifTrue: [^programmedMoves := programmedMoves allButFirst].

!

----- Method: ZoomAndScrollControllerMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas

| dw bullsEye f |

super drawOn: aCanvas.
changeKeysState ifNotNil: [
f := (
StringMorph contents: 'Press the key to be used for "',changeKeysState first,'"'
) imageForm.
aCanvas paintImage: f at: self center - (f extent // 2).
^self
].
mouseDownPoint ifNil: [^self].
dw := self deadZoneWidth.
bullsEye := mouseDownPoint - (dw@dw//2) extent: dw@dw.
aCanvas
fillRectangle: (bullsEye left @ self top corner: bullsEye right @ self bottom)
color: (Color red alpha: 0.3).
aCanvas
fillRectangle: (self left @ bullsEye top corner: self right @ bullsEye bottom)
color: (Color red alpha: 0.3).
aCanvas
fillRectangle: bullsEye
color: (Color red alpha: 0.4).
!

----- Method: ZoomAndScrollControllerMorph>>editAScript (in category 'as yet unclassified') -----
editAScript

| d names reply s |
d := self targetScriptDictionary.
names := d keys asSortedCollection.
reply := UIManager default chooseFrom: names values: names title: 'Script to edit?'.
reply ifNil: [^ self].
(s := ZASMScriptMorph new)
decompileScript: (d at: reply) named: reply for: self;
fullBounds;
align: s center with: self center;
openInWorld
!

----- Method: ZoomAndScrollControllerMorph>>fractionLeftInMove: (in category 'as yet unclassified') -----
fractionLeftInMove: thisMove

| steps stepsRemaining fractionLeft endTime startTime |

(thisMove includesKey: #steps) ifTrue: [
steps := thisMove at: #steps ifAbsentPut: [1].
stepsRemaining := thisMove at: #stepsRemaining ifAbsentPut: [steps].
stepsRemaining < 1 ifTrue: [^nil].
stepsRemaining := stepsRemaining - 1.
fractionLeft := stepsRemaining / steps.
thisMove at: #stepsRemaining put: stepsRemaining.
] ifFalse: [
endTime := thisMove at: #endTime ifAbsent: [^nil].
startTime := thisMove at: #startTime ifAbsent: [^nil].
fractionLeft := (endTime - Time millisecondClockValue) / (endTime - startTime).
].
^fractionLeft max: 0
!

----- Method: ZoomAndScrollControllerMorph>>grabCameraPositionEvent:morph: (in category 'as yet unclassified') -----
grabCameraPositionEvent: anEvent morph: aMorph

| mark |
mark := ZASMCameraMarkMorph new.
mark
cameraPoint: self cameraPoint
cameraScale: self cameraScale
controller: self
page: target.
anEvent hand attachMorph: mark.!

----- Method: ZoomAndScrollControllerMorph>>handlesKeyboard: (in category 'event handling') -----
handlesKeyboard: evt

^true!

----- Method: ZoomAndScrollControllerMorph>>handlesMouseDown: (in category 'event handling') -----
handlesMouseDown: evt

^true!

----- Method: ZoomAndScrollControllerMorph>>handlesMouseOver: (in category 'event handling') -----
handlesMouseOver: evt

^true!

----- Method: ZoomAndScrollControllerMorph>>hasFocus (in category 'event handling') -----
hasFocus

^ hasFocus!

----- Method: ZoomAndScrollControllerMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
| displayer dataMorph |
super initialize.
""
hasFocus := true.
currentKeyDown := Set new.
upDownCodes := Dictionary new.
upDownCodes at: 126 put: #up;
at: 125 put: #down;
at: 123 put: #out;
at: 124 put: #in.
"arrow keys on the mac"
self extent: 40 @ 40;
vResizing: #rigid;
hResizing: #spaceFill;
setBalloonText: 'Drag in here to zoom, tilt and pan the page above'.
dataMorph := AlignmentMorph newColumn.
dataMorph color: Color yellow;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap.
dataMorph
on: #mouseDown
send: #grabCameraPositionEvent:morph:
to: self.
displayer := UpdatingStringMorph new getSelector: #cameraPointRounded;
target: self;
growable: true;
putSelector: nil.
dataMorph addMorph: displayer lock.
displayer := UpdatingStringMorph new getSelector: #cameraScale;
target: self;
growable: true;
floatPrecision: 0.001;
putSelector: nil.
dataMorph addMorph: displayer lock.
self addMorph: dataMorph!

----- Method: ZoomAndScrollControllerMorph>>keyDown: (in category 'event handling') -----
keyDown: anEvent

changeKeysState ifNotNil: [
upDownCodes at: anEvent keyValue put: changeKeysState first.
changeKeysState := changeKeysState allButFirst.
changeKeysState isEmpty ifTrue: [changeKeysState := nil].
currentKeyDown := Set new.
^self changed
].
currentKeyDown add: anEvent keyValue.
!

----- Method: ZoomAndScrollControllerMorph>>keyStroke: (in category 'event handling') -----
keyStroke: anEvent

!

----- Method: ZoomAndScrollControllerMorph>>keyUp: (in category 'event handling') -----
keyUp: anEvent

currentKeyDown remove: anEvent keyValue ifAbsent: [].!

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

mouseDownPoint := evt cursorPoint.
self changed.!

----- Method: ZoomAndScrollControllerMorph>>mouseEnter: (in category 'event handling') -----
mouseEnter: evt

evt hand newKeyboardFocus: self.
currentKeyDown := Set new.
hasFocus := true.

!

----- Method: ZoomAndScrollControllerMorph>>mouseLeave: (in category 'event handling') -----
mouseLeave: evt

currentKeyDown := Set new.
hasFocus := false.
mouseMovePoint := mouseDownPoint := nil.
!

----- Method: ZoomAndScrollControllerMorph>>mouseMove: (in category 'event handling') -----
mouseMove: evt

mouseMovePoint := evt cursorPoint.

!

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

mouseMovePoint := mouseDownPoint := nil.
self changed.!

----- Method: ZoomAndScrollControllerMorph>>patchOldVersion1 (in category 'as yet unclassified') -----
patchOldVersion1

"hack.. use this as an opportunity to fix old versions"
self allMorphsDo: [:m |
((m isKindOf: UpdatingStringMorph) and: [m getSelector == #cameraPoint]) ifTrue: [
m getSelector: #cameraPointRounded
].
].

!

----- Method: ZoomAndScrollControllerMorph>>pauseProgrammedMoves (in category 'as yet unclassified') -----
pauseProgrammedMoves

programmedMoves isEmptyOrNil ifTrue: [^self].
programmedMoves first
at: #pauseTime
put: Time millisecondClockValue
!

----- Method: ZoomAndScrollControllerMorph>>resumeProgrammedMoves (in category 'as yet unclassified') -----
resumeProgrammedMoves

| thisStep |

programmedMoves isEmptyOrNil ifTrue: [^self].
(thisStep := programmedMoves first)
at: #pauseTime
ifPresent: [ :pauseTime |
thisStep
at: #startTime
put: (thisStep at: #startTime) + Time millisecondClockValue - pauseTime.
thisStep removeKey: #pauseTime ifAbsent: [].
].
!

----- Method: ZoomAndScrollControllerMorph>>runAScript (in category 'as yet unclassified') -----
runAScript

| d names reply |
d := self targetScriptDictionary.
names := d keys asSortedCollection.
reply := UIManager default chooseFrom: names values: names title: 'Script to run?'.
reply ifNil: [^ self].
programmedMoves := (d at: reply) veryDeepCopy.!

----- Method: ZoomAndScrollControllerMorph>>saveScript:as: (in category 'as yet unclassified') -----
saveScript: newScript as: scriptName

self targetScriptDictionary at: scriptName put: newScript.

!

----- Method: ZoomAndScrollControllerMorph>>setProgrammedMoves: (in category 'as yet unclassified') -----
setProgrammedMoves: aCollection

programmedMoves := aCollection
!

----- Method: ZoomAndScrollControllerMorph>>step (in category 'stepping and presenter') -----
step

| delta halfDW action |

(self valueOfProperty: #currentCameraVersion ifAbsent: [0]) =
self currentCameraVersion ifFalse: [
self patchOldVersion1.
self setProperty: #currentCameraVersion toValue: self currentCameraVersion.
].
super step.
self doProgrammedMoves.

(currentKeyDown ifNil: [#()]) do: [ :each |
action := upDownCodes at: each ifAbsent: [#fugeddaboutit].
action == #in ifTrue: [
target scaleImageBy: -10.
].
action == #out ifTrue: [
target scaleImageBy: 10.
].
action == #up ifTrue: [
target tiltImageBy: -20.
].
action == #down ifTrue: [
target tiltImageBy: 20.
].
].
mouseMovePoint ifNil: [^self].
mouseDownPoint ifNil: [^self].
target ifNil: [^self].
halfDW := self deadZoneWidth // 2.
delta := mouseMovePoint - mouseDownPoint.
delta x abs <= halfDW ifTrue: [delta := 0@delta y].
delta y abs <= halfDW ifTrue: [delta := delta x@0].

target panImageBy: delta x.

!

----- Method: ZoomAndScrollControllerMorph>>stepTime (in category 'testing') -----
stepTime

^10

!

----- Method: ZoomAndScrollControllerMorph>>target: (in category 'as yet unclassified') -----
target: x

target := x.
!

----- Method: ZoomAndScrollControllerMorph>>targetScriptDictionary (in category 'as yet unclassified') -----
targetScriptDictionary

| scriptDict |
target ifNil: [^Dictionary new].
^target
valueOfProperty: #namedCameraScripts
ifAbsent: [
scriptDict := Dictionary new.
target setProperty: #namedCameraScripts toValue: scriptDict.
scriptDict
].

!

----- Method: ZoomAndScrollControllerMorph>>turnToPage:position:scale:transition: (in category 'as yet unclassified') -----
turnToPage: page position: aPoint scale: aNumber transition: aSpec

| myBook |

target == page ifTrue: [^false].
page ifNil: [^false].
myBook := (self ownerThatIsA: StoryboardBookMorph) ifNil: [^ false].
2 timesRepeat: [
page
cameraPoint: aPoint;
changeScaleTo: aNumber
].
BookMorph turnOffSoundWhile: [
myBook
goToPageMorph: page
transitionSpec: aSpec.
].
^true!

StringMorph subclass: #ClockMorph
instanceVariableNames: 'showSeconds show24hr'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

----- Method: ClockMorph class>>authoringPrototype (in category 'scripting') -----
authoringPrototype
^ super authoringPrototype contents: Time now printString!

----- Method: ClockMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Clock'
categories: #('Useful')
documentation: 'A digital clock'!

----- Method: ClockMorph class>>initialize (in category 'class initialization') -----
initialize

self registerInFlapsRegistry. !

----- Method: ClockMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(ClockMorph authoringPrototype 'Clock' 'A simple digital clock')
forFlapNamed: 'Supplies'.
cl registerQuad: #(ClockMorph authoringPrototype 'Clock' 'A simple digital clock')
forFlapNamed: 'PlugIn Supplies'.]!

----- Method: ClockMorph class>>unload (in category 'class initialization') -----
unload
"Unload the receiver from global registries"

self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] !

----- Method: ClockMorph>>addCustomMenuItems:hand: (in category 'menu') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph
"Note minor loose end here -- if the menu is persistent, then the wording will be wrong half the time"
| item |
super addCustomMenuItems: aCustomMenu hand: aHandMorph.
item := showSeconds == true
ifTrue: ['stop showing seconds']
ifFalse: ['start showing seconds'].
aCustomMenu add: item translated target: self action: #toggleShowingSeconds.
item := show24hr == true
ifTrue: ['display Am/Pm']
ifFalse: ['display 24 hour'].
aCustomMenu add: item translated target: self action: #toggleShowing24hr.

!

----- Method: ClockMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
showSeconds := true.
show24hr := false.
self step!

----- Method: ClockMorph>>initializeToStandAlone (in category 'parts bin') -----
initializeToStandAlone
super initializeToStandAlone.
showSeconds := true.
self step!

----- Method: ClockMorph>>show24hr: (in category '24hr') -----
show24hr: aBoolean
show24hr := aBoolean!

----- Method: ClockMorph>>showSeconds: (in category 'seconds') -----
showSeconds: aBoolean
showSeconds := aBoolean!

----- Method: ClockMorph>>step (in category 'stepping and presenter') -----
step
| time |
super step.
time := String streamContents:
[:aStrm | Time now print24: (show24hr == true) showSeconds: (showSeconds == true) on: aStrm].

self contents: time !

----- Method: ClockMorph>>stepTime (in category 'testing') -----
stepTime
"Answer the desired time between steps in milliseconds."

^ 1000!

----- Method: ClockMorph>>toggleShowing24hr (in category '24hr') -----
toggleShowing24hr
show24hr := (show24hr == true) not
!

----- Method: ClockMorph>>toggleShowingSeconds (in category 'seconds') -----
toggleShowingSeconds
showSeconds := (showSeconds == true) not
!

StringMorph subclass: #FrameRateMorph
instanceVariableNames: 'lastDisplayTime framesSinceLastDisplay'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

----- Method: FrameRateMorph class>>authoringPrototype (in category 'scripting') -----
authoringPrototype
"Answer a morph representing a prototypical instance of the receiver"

| aMorph |
aMorph := self new.
aMorph color: Color blue.
aMorph step.
^ aMorph!

----- Method: FrameRateMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'FrameRate'
categories: #('Useful')
documentation: 'A readout that allows you to monitor the frame rate of your system'!

----- Method: FrameRateMorph class>>initialize (in category 'class initialization') -----
initialize

self registerInFlapsRegistry. !

----- Method: FrameRateMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(FrameRateMorph authoringPrototype 'Frame Rate' 'An indicator of how fast your system is running')
forFlapNamed: 'Widgets']!

----- Method: FrameRateMorph class>>unload (in category 'class initialization') -----
unload
"Unload the receiver from global registries"

self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] !

----- Method: FrameRateMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
lastDisplayTime := 0.
framesSinceLastDisplay := 0!

----- Method: FrameRateMorph>>initializeToStandAlone (in category 'parts bin') -----
initializeToStandAlone
"Initialize the receiver as a stand-alone entity"

super initializeToStandAlone.
self color: Color blue.
self step!

----- Method: FrameRateMorph>>step (in category 'stepping and presenter') -----
step
"Compute and display (every half second or so) the current framerate"

| now mSecs mSecsPerFrame framesPerSec newContents |
framesSinceLastDisplay := framesSinceLastDisplay + 1.
now := Time millisecondClockValue.
mSecs := now - lastDisplayTime.
(mSecs > 500 or: [mSecs < 0 "clock wrap-around"]) ifTrue:
[mSecsPerFrame := mSecs // framesSinceLastDisplay.
framesPerSec := (framesSinceLastDisplay * 1000) // mSecs.
newContents := mSecsPerFrame printString, ' mSecs (', framesPerSec printString, ' frame', (framesPerSec == 1 ifTrue: [''] ifFalse: ['s']), '/sec)'.
self contents: newContents.
lastDisplayTime := now.
framesSinceLastDisplay := 0]!

----- Method: FrameRateMorph>>stepTime (in category 'testing') -----
stepTime
"Answer the desired time between steps in milliseconds."

^ 0
!

StringMorph subclass: #ZASMStepsMorph
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

----- Method: ZASMStepsMorph>>getStepCount (in category 'as yet unclassified') -----
getStepCount

^[self contents asNumber] ifError: [ :a :b | 10]

!

----- Method: ZASMStepsMorph>>handlesMouseDown: (in category 'event handling') -----
handlesMouseDown: evt

^ true!

----- Method: ZASMStepsMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
"If the shift key is pressed, make this string the keyboard input focus."

self launchMiniEditor: evt
!

----- Method: ZASMStepsMorph>>setStepCount: (in category 'as yet unclassified') -----
setStepCount: n

self contents: n printString.

!

BorderedMorph subclass: #MagnifierMorph
instanceVariableNames: 'magnification trackPointer srcExtent showPointer'
classVariableNames: 'RecursionLock'
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

!MagnifierMorph commentStamp: '<historical>' prior: 0!
MagnifierMorph instances are magnifying lenses that magnify the morphs below them (if grabbed or if trackPointer is false) or the area around the mouse pointer.

Instance variables:

magnification <Number> The magnification to use. If non-integer, smooths the magnified form.

trackPointer <Boolean> If set, magnifies the area around the Hand. If not, magnfies the area underneath the magnifier center.

showPointer <Boolean> If set, display a small reversed rectangle in the center of the lens. Also enables the display of Morphs in the Hand itself.

srcExtent <Rectangle> The extent of the source rectangle.

Class variables:

RecursionLock <MagnifierMorph|nil> Used to avoid infinite recursion when getting the source patch to display.!

----- Method: MagnifierMorph class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
^ self partName: 'Magnifier'
categories: #('Useful')
documentation: 'A magnifying glass'!

----- Method: MagnifierMorph class>>initialize (in category 'class initialization') -----
initialize

self registerInFlapsRegistry.!

----- Method: MagnifierMorph class>>newRound (in category 'instance creation') -----
newRound
"Answer a round Magnifier"

| aMagnifier sm |
aMagnifier := self new.
sm := ScreeningMorph new position: aMagnifier position.
sm addMorph: aMagnifier.
sm addMorph: (EllipseMorph newBounds: aMagnifier bounds).
sm setNameTo: 'Magnifier'.
^ sm!

----- Method: MagnifierMorph class>>newShowingPointer (in category 'instance creation') -----
newShowingPointer
"Answer a Magnifier that also displays Morphs in the Hand and the Hand position"

^(self new)
showPointer: true;
setNameTo: 'HandMagnifier';
yourself!

----- Method: MagnifierMorph class>>registerInFlapsRegistry (in category 'class initialization') -----
registerInFlapsRegistry
"Register the receiver in the system's flaps registry"
self environment
at: #Flaps
ifPresent: [:cl | cl registerQuad: #(MagnifierMorph newRound 'Magnifier' 'A magnifying glass')
forFlapNamed: 'Widgets']!

----- Method: MagnifierMorph class>>supplementaryPartsDescriptions (in category 'parts bin') -----
supplementaryPartsDescriptions
^ {DescriptionForPartsBin
formalName: 'RoundGlass'
categoryList: #(Useful)
documentation: 'A round magnifying glass'
globalReceiverSymbol: #MagnifierMorph
nativitySelector: #newRound.

DescriptionForPartsBin
formalName: 'Hand Magnifier'
categoryList: #(Useful)
documentation: 'A magnifying glass that also shows Morphs in the Hand and displays the Hand position.'
globalReceiverSymbol: #MagnifierMorph
nativitySelector: #newShowingPointer }!

----- Method: MagnifierMorph class>>unload (in category 'class initialization') -----
unload
"Unload the receiver from global registries"

self environment at: #Flaps ifPresent: [:cl |
cl unregisterQuadsWithReceiver: self] !

----- Method: MagnifierMorph>>addCustomMenuItems:hand: (in category 'menu') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph
super addCustomMenuItems: aCustomMenu hand: aHandMorph.
aCustomMenu
addLine;
add: 'magnification...' translated action: #chooseMagnification;
addUpdating: #trackingPointerString action: #toggleTrackingPointer;
addUpdating: #showingPointerString action: #toggleShowingPointer;
addUpdating: #toggleRoundString action: #toggleRoundness.!

----- Method: MagnifierMorph>>borderWidth: (in category 'accessing') -----
borderWidth: anInteger
"Grow outwards preserving innerBounds"
| c |
c := self center.
super borderWidth: anInteger.
super extent: self defaultExtent.
self center: c.!

----- Method: MagnifierMorph>>chooseMagnification (in category 'menu') -----
chooseMagnification
| result |
result := UIManager default chooseFrom: #(1.5 2 4 8) values: #(1.5 2 4 8)
title: ('Choose magnification
(currently {1})' translated format:{magnification}).
(result isNil or: [result = magnification]) ifTrue: [^ self].
magnification := result.
self extent: self extent. "round to new magnification"
self changed. "redraw even if extent wasn't changed"!

----- Method: MagnifierMorph>>chooseMagnification: (in category 'menu') -----
chooseMagnification: evt
| handle origin aHand currentMag |
currentMag := magnification.
aHand := evt ifNil: [self currentHand] ifNotNil: [evt hand].
origin := aHand position y.
handle := HandleMorph new forEachPointDo:
[:newPoint | self magnification: (newPoint y - origin) / 8.0 + currentMag].
aHand attachMorph: handle.
handle startStepping.
self changed. "Magnify handle"!

----- Method: MagnifierMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 1!

----- Method: MagnifierMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color black!

----- Method: MagnifierMorph>>defaultExtent (in category 'geometry') -----
defaultExtent
^(srcExtent * magnification) truncated + (2 * borderWidth)!

----- Method: MagnifierMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
super drawOn: aCanvas. "border and fill"
aCanvas isShadowDrawing ifFalse: [
"Optimize because #magnifiedForm is expensive"
aCanvas paintImage: self magnifiedForm at: self innerBounds origin]!

----- Method: MagnifierMorph>>extent: (in category 'geometry') -----
extent: aPoint
"Round to multiples of magnification"
srcExtent := (aPoint - (2 * borderWidth)) // magnification.
^super extent: self defaultExtent!

----- Method: MagnifierMorph>>handlesMouseDown: (in category 'event handling') -----
handlesMouseDown: evt
^evt yellowButtonPressed
or: [super handlesMouseDown: evt]!

----- Method: MagnifierMorph>>hasTranslucentColor (in category 'accessing') -----
hasTranslucentColor
"I may show what's behind me, so tell the hand to don't cache"
^self sourceRect intersects: self bounds!

----- Method: MagnifierMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.

trackPointer := true.
showPointer := false.
magnification := 2.

self extent: 128 @ 128!

----- Method: MagnifierMorph>>isRound (in category 'round view') -----
isRound

^ owner isMemberOf: ScreeningMorph!

----- Method: MagnifierMorph>>magnification: (in category 'magnifying') -----
magnification: aNumber
| c |
magnification := aNumber min: 8 max: 0.5.
magnification := magnification roundTo:
(magnification < 3 ifTrue: [0.5] ifFalse: [1]).
srcExtent := srcExtent min: (512@512) // magnification. "to prevent accidents"
c := self center.
super extent: self defaultExtent.
self center: c.!

----- Method: MagnifierMorph>>magnifiedForm (in category 'magnifying') -----
magnifiedForm
"Answer the magnified form"
| srcRect form exclusion magnified |
srcRect := self sourceRectFrom: self sourcePoint.
(RecursionLock isNil and: [ self showPointer or: [ srcRect intersects: self bounds ]])
ifTrue: [RecursionLock := self.
exclusion := self isRound
ifTrue: [owner]
ifFalse: [self].
form := self currentWorld
patchAt: srcRect
without: exclusion
andNothingAbove: false.
RecursionLock := nil]
ifFalse: ["cheaper method if the source is not occluded"
form := Display copy: srcRect].
"smooth if non-integer scale"
magnified := form
magnify: form boundingBox
by: magnification
smoothing: (magnification isInteger
ifTrue: [1]
ifFalse: [2]).
"display the pointer rectangle if desired"
self showPointer
ifTrue: [magnified
reverse: (magnified center - (2 @ 2) extent: 4 @ 4)
fillColor: Color white].
^ magnified!

----- Method: MagnifierMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
evt yellowButtonPressed
ifTrue: [self chooseMagnification: evt]
ifFalse: [super mouseDown: evt]!

----- Method: MagnifierMorph>>showPointer (in category 'menu') -----
showPointer
^showPointer ifNil: [ showPointer := false ].!

----- Method: MagnifierMorph>>showPointer: (in category 'accessing') -----
showPointer: aBoolean
"If aBoolean is true, display the current pointer position as a small square in the center of the lens."

showPointer == aBoolean ifTrue: [ ^self ].
showPointer := aBoolean.
self changed.!

----- Method: MagnifierMorph>>showingPointerString (in category 'menu') -----
showingPointerString
^ (self showPointer
ifTrue: ['stop showing pointer']
ifFalse: ['start showing pointer']) translated!

----- Method: MagnifierMorph>>sourcePoint (in category 'magnifying') -----
sourcePoint
"If we are being dragged use our center, otherwise use pointer position"
^(trackPointer not or: [owner notNil and: [owner isHandMorph]])
ifTrue: [self center]
ifFalse: [self currentHand position]!

----- Method: MagnifierMorph>>sourceRect (in category 'magnifying') -----
sourceRect
^self sourceRectFrom: self sourcePoint
!

----- Method: MagnifierMorph>>sourceRectFrom: (in category 'magnifying') -----
sourceRectFrom: aPoint
^ (aPoint extent: srcExtent) translateBy: (srcExtent // -2) + 1.
!

----- Method: MagnifierMorph>>step (in category 'stepping and presenter') -----
step
self changed!

----- Method: MagnifierMorph>>stepTime (in category 'testing') -----
stepTime
^ 0!

----- Method: MagnifierMorph>>toggleRoundString (in category 'round view') -----
toggleRoundString
^ (self isRound
ifTrue: ['be square']
ifFalse: ['be round']) translated!

----- Method: MagnifierMorph>>toggleRoundness (in category 'round view') -----
toggleRoundness
| sm w |
w := self world.
self isRound
ifTrue: [owner delete.
w addMorph: self]
ifFalse: [sm := ScreeningMorph new position: self position.
sm addMorph: self.
sm addMorph: (EllipseMorph newBounds: self bounds).
w addMorph: sm]!

----- Method: MagnifierMorph>>toggleShowingPointer (in category 'menu') -----
toggleShowingPointer
self showPointer: self showPointer not!

----- Method: MagnifierMorph>>toggleTrackingPointer (in category 'menu') -----
toggleTrackingPointer
trackPointer := trackPointer not!

----- Method: MagnifierMorph>>trackingPointerString (in category 'menu') -----
trackingPointerString
^ (trackPointer
ifTrue: ['stop tracking pointer']
ifFalse: ['start tracking pointer']) translated!

PasteUpMorph subclass: #ZASMScriptMorph
instanceVariableNames: 'somethingChanged'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

----- Method: ZASMScriptMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: aMorph event: evt

super acceptDroppingMorph: aMorph event: evt.
somethingChanged := true.
!

----- Method: ZASMScriptMorph>>addCustomMenuItems:hand: (in category 'menus') -----
addCustomMenuItems: aCustomMenu hand: aHandMorph

super addCustomMenuItems: aCustomMenu hand: aHandMorph.
aCustomMenu addLine.
aCustomMenu add: 'save script' translated action: #saveScript.

!

----- Method: ZASMScriptMorph>>compileScript (in category 'as yet unclassified') -----
compileScript

| newScript prevMark prevSteps data |

self fixup.
newScript := OrderedCollection new.
prevMark := prevSteps := nil.
submorphs do: [ :each |
(each isKindOf: ZASMCameraMarkMorph) ifTrue: [
prevMark ifNotNil: [
data := Dictionary new.
data
at: #steps put: prevSteps;
at: #startPoint put: (prevMark valueOfProperty: #cameraPoint);
at: #endPoint put: (each valueOfProperty: #cameraPoint);
at: #startZoom put: (prevMark valueOfProperty: #cameraScale);
at: #endZoom put: (each valueOfProperty: #cameraScale).
newScript add: data.
].
prevMark := each.
].
(each isKindOf: ZASMStepsMorph) ifTrue: [
prevSteps := each getStepCount.
].
].
^newScript
!

----- Method: ZASMScriptMorph>>decompileScript:named:for: (in category 'as yet unclassified') -----
decompileScript: aScript named: aString for: aController

| newMorphs prevPt prevScale cameraPoint cameraScale mark |

self removeAllMorphs.
self setProperty: #cameraController toValue: aController.
self setProperty: #cameraScriptName toValue: aString.

newMorphs := OrderedCollection new.
prevPt := prevScale := nil.
aScript do: [ :each |
cameraPoint := each at: #startPoint ifAbsent: [nil].
cameraScale := each at: #startZoom ifAbsent: [nil].
(prevPt = cameraPoint and: [prevScale = cameraScale]) ifFalse: [
mark := ZASMCameraMarkMorph new.
mark cameraPoint: cameraPoint cameraScale: cameraScale controller: aController.
newMorphs add: mark.
].
newMorphs add: (ZASMStepsMorph new setStepCount: (each at: #steps ifAbsent: [10])).
cameraPoint := each at: #endPoint ifAbsent: [nil].
cameraScale := each at: #endZoom ifAbsent: [nil].
mark := ZASMCameraMarkMorph new.
mark cameraPoint: cameraPoint cameraScale: cameraScale controller: aController.
newMorphs add: mark.
prevPt := cameraPoint.
prevScale := cameraScale.
].
self addAllMorphs: newMorphs.
!

----- Method: ZASMScriptMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ Color blue!

----- Method: ZASMScriptMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 2!

----- Method: ZASMScriptMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightBlue!

----- Method: ZASMScriptMorph>>fixup (in category 'as yet unclassified') -----
fixup

| newMorphs state fixed |

somethingChanged := false.
newMorphs := OrderedCollection new.
state := #new.
fixed := false.
submorphs do: [ :each |
(each isKindOf: ZASMCameraMarkMorph) ifTrue: [
state == #mark ifTrue: [
newMorphs add: (
ZASMStepsMorph new setStepCount: 10
).
fixed := true.
].
newMorphs add: each.
state := #mark.
].
(each isKindOf: ZASMStepsMorph) ifTrue: [
state == #steps ifTrue: [
fixed := true.
] ifFalse: [
newMorphs add: each.
state := #steps.
].
].
].
fixed ifTrue: [
self removeAllMorphs.
self addAllMorphs: newMorphs.
].!

----- Method: ZASMScriptMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
somethingChanged := true.
self dragEnabled: true;
layoutPolicy: TableLayout new;
listDirection: #topToBottom;
wrapCentering: #topLeft;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
layoutInset: 6;

rubberBandCells: true!

----- Method: ZASMScriptMorph>>layoutChanged (in category 'layout') -----
layoutChanged

super layoutChanged.
somethingChanged := true.

!

----- Method: ZASMScriptMorph>>saveScript (in category 'as yet unclassified') -----
saveScript

| newScript scriptName |
newScript := self compileScript.
scriptName := UIManager default
request: 'Name this script'
initialAnswer: (self valueOfProperty: #cameraScriptName ifAbsent: ['']).
scriptName isEmptyOrNil ifTrue: [^self].
(self valueOfProperty: #cameraController)
saveScript: newScript
as: scriptName.
self delete.!

----- Method: ZASMScriptMorph>>step (in category 'stepping and presenter') -----
step

super step.
somethingChanged ifFalse: [^self].
self fixup.
!

----- Method: ZASMScriptMorph>>stepTime (in category 'testing') -----
stepTime

^500!

----- Method: ZASMScriptMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt

^aMorph isKindOf: ZASMCameraMarkMorph!

----- Method: ZASMScriptMorph>>wantsSteps (in category 'testing') -----
wantsSteps

^true!

PasteUpMorph subclass: #ZoomAndScrollMorph
instanceVariableNames: 'sourceRectangle usingBalloon panAndTiltFactor zoomFactor'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

!ZoomAndScrollMorph commentStamp: '<historical>' prior: 0!
I am the outer part of a transformed view of another pasteup. I know how to translate requests to pan, tilt and zoom into appropriate changes to the transformation!

----- Method: ZoomAndScrollMorph>>acceptDroppingMorph:event: (in category 'layout') -----
acceptDroppingMorph: morphToDrop event: evt

^morphToDrop rejectDropMorphEvent: evt. "put it back where it came from"

!

----- Method: ZoomAndScrollMorph>>cameraPoint (in category 'scripting') -----
cameraPoint

^self myTransformMorph transform globalPointToLocal: self innerBounds center

!

----- Method: ZoomAndScrollMorph>>cameraPoint: (in category 'scripting') -----
cameraPoint: newPt

| transform |

transform := self myTransformMorph.
self changeOffsetTo: newPt * transform scale - (transform innerBounds extent // 2)

!

----- Method: ZoomAndScrollMorph>>changeOffsetBy: (in category 'as yet unclassified') -----
changeOffsetBy: aPoint

| transform rounder roundPt |

"improve behavior at high magnification by rounding change to whole source pixels"
transform := self myTransformMorph.
rounder := [ :val |
"(val abs + (transform scale * 0.99) roundTo: transform scale) * val sign"
"looks like rounding wasn't a good solution"
val
].
roundPt := (rounder value: aPoint x) @ (rounder value: aPoint y).

self changeOffsetTo: transform offset + roundPt.
!

----- Method: ZoomAndScrollMorph>>changeOffsetTo: (in category 'as yet unclassified') -----
changeOffsetTo: aPoint

| transform trialOffset innerPasteup keepWidth keepHeight |

transform := self myTransformMorph.
keepWidth := transform width "// 4".
keepHeight := transform height "// 4".
innerPasteup := transform firstSubmorph.
trialOffset := aPoint.
trialOffset :=
(trialOffset x
min: (innerPasteup width * transform scale) - keepWidth
max: keepWidth - transform width) @
(trialOffset y
min: (innerPasteup height * transform scale) - keepHeight
max: keepHeight - transform height).
transform offset: trialOffset.

!

----- Method: ZoomAndScrollMorph>>changeScaleTo: (in category 'as yet unclassified') -----
changeScaleTo: aNumber

| transform innerPasteup min1 min2 newScale oldPoint |

transform := self myTransformMorph.
"oldScale := transform scale."
innerPasteup := transform firstSubmorph.

min1 := transform width / innerPasteup width asFloat.
min2 := transform height / innerPasteup height asFloat.
newScale := (aNumber max: min1) max: min2.

oldPoint := self cameraPoint.
transform scale: newScale.
self cameraPoint: oldPoint.

"scaleR := newScale / oldScale.
half := transform extent // 2.
half := 0@0.
self changeOffsetBy: scaleR * (transform offset + half) - half - transform offset."

"==Alan's preferred factors
pan = 0.0425531914893617
zoom = 0.099290780141844
==="
!

----- Method: ZoomAndScrollMorph>>changeTiltFactor: (in category 'as yet unclassified') -----
changeTiltFactor: x

panAndTiltFactor := x!

----- Method: ZoomAndScrollMorph>>changeZoomFactor: (in category 'as yet unclassified') -----
changeZoomFactor: x

zoomFactor := x!

----- Method: ZoomAndScrollMorph>>createInteriorTransform (in category 'initialization') -----
createInteriorTransform

| innerPasteUp tm |
innerPasteUp := PasteUpMorph new.
innerPasteUp
borderWidth: 0;
minHeight: 100;
minWidth: 100;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
position: 0@0;
extent: 100@100.
tm := TransformationB2Morph new.
tm setProperty: #rotationCenter toValue: 0@0.
tm useRegularWarpBlt: usingBalloon not.
self addMorph: tm.
tm addMorph: innerPasteUp.
tm beSticky.
innerPasteUp beSticky.
tm
scale: 1.0;
offset: 0@0.
!

----- Method: ZoomAndScrollMorph>>defaultBorderColor (in category 'initialization') -----
defaultBorderColor
"answer the default border color/fill style for the receiver"
^ Color red!

----- Method: ZoomAndScrollMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color lightGray!

----- Method: ZoomAndScrollMorph>>extent: (in category 'geometry') -----
extent: extentPoint

super extent: extentPoint.
self myTransformMorph bounds: self innerBounds.
!

----- Method: ZoomAndScrollMorph>>getTiltFactor (in category 'as yet unclassified') -----
getTiltFactor

^panAndTiltFactor ifNil: [panAndTiltFactor := 0.5].

!

----- Method: ZoomAndScrollMorph>>getZoomFactor (in category 'as yet unclassified') -----
getZoomFactor

^zoomFactor ifNil: [zoomFactor := 0.5].

!

----- Method: ZoomAndScrollMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
usingBalloon := true.
self createInteriorTransform !

----- Method: ZoomAndScrollMorph>>myTransformMorph (in category 'scripting') -----
myTransformMorph

^self firstSubmorph
!

----- Method: ZoomAndScrollMorph>>offsetX (in category 'scripting') -----
offsetX

^self myTransformMorph offset x
!

----- Method: ZoomAndScrollMorph>>offsetX: (in category 'scripting') -----
offsetX: aNumber

| transform |

transform := self myTransformMorph.
transform offset: aNumber @ transform offset y
!

----- Method: ZoomAndScrollMorph>>offsetY (in category 'scripting') -----
offsetY

^self myTransformMorph offset y
!

----- Method: ZoomAndScrollMorph>>offsetY: (in category 'scripting') -----
offsetY: aNumber

| transform |

transform := self myTransformMorph.
transform offset: transform offset x @ aNumber
!

----- Method: ZoomAndScrollMorph>>panImageBy: (in category 'as yet unclassified') -----
panImageBy: pixels

self changeOffsetBy: (pixels * self getTiltFactor * 0.1) @ 0.

"steps := (pixels abs / 6) exp rounded * pixels sign."
"==Alan's preferred factors
pan = 0.0425531914893617
zoom = 0.099290780141844
==="

!

----- Method: ZoomAndScrollMorph>>scale (in category 'scripting') -----
scale

^self myTransformMorph scale
!

----- Method: ZoomAndScrollMorph>>scale: (in category 'scripting') -----
scale: aValue

self myTransformMorph scale: aValue.
!

----- Method: ZoomAndScrollMorph>>scaleImageBy: (in category 'as yet unclassified') -----
scaleImageBy: pixels

| scalePerPixel steps transform factor |

transform := self myTransformMorph.
(steps := (pixels * self getZoomFactor * 0.2) rounded) = 0 ifTrue: [^self].
scalePerPixel := 1.01.
factor := scalePerPixel raisedTo: steps abs.
steps > 0 ifTrue: [
factor := 1.0 / factor.
].
self changeScaleTo: (transform scale * factor min: 10.0 max: 0.1).
!

----- Method: ZoomAndScrollMorph>>step (in category 'stepping and presenter') -----
step

| innerPasteUp overlap |

innerPasteUp := self myTransformMorph firstSubmorph.
overlap := (innerPasteUp submorphs
inject: 0@0
into: [ :min :each | min min: each position]) rounded.
overlap = (0@0) ifFalse: [
innerPasteUp submorphs do: [ :each | each position: each position - overlap].
innerPasteUp layoutChanged.
].

!

----- Method: ZoomAndScrollMorph>>stepTime (in category 'testing') -----
stepTime

^10 "ms"!

----- Method: ZoomAndScrollMorph>>tiltImageBy: (in category 'as yet unclassified') -----
tiltImageBy: pixels

self changeOffsetBy: 0 @ (pixels * self getTiltFactor * 0.1)

" steps := (pixels abs / 6) exp rounded * pixels sign.
"
"==Alan's preferred factors
pan = 0.0425531914893617
zoom = 0.099290780141844
==="
!

----- Method: ZoomAndScrollMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt

"we don't, really, but it avoids problem of outer pasteup rejecting a drop for inner pasteup"
^true!

EllipseMorph subclass: #AtomMorph
instanceVariableNames: 'velocity'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

!AtomMorph commentStamp: 'tbn 11/25/2004 09:06' prior: 0!
AtomMorph represents an atom used in the simulation of
an ideal gas. It's container is typically a BouncingAtomsMorph.

Try:

BouncingAtomsMorph new openInWorld

to open the gas simulation or:

AtomMorph example

to open an instance in the current world!

----- Method: AtomMorph class>>example (in category 'examples') -----
example
"
AtomMorph example
"
|a|
a := AtomMorph new openInWorld.
a color: Color random.
[1000 timesRepeat: [a bounceIn: World bounds. (Delay forMilliseconds: 50) wait].
a delete] fork.!

----- Method: AtomMorph class>>includeInNewMorphMenu (in category 'new-morph participation') -----
includeInNewMorphMenu
"Not to be instantiated from the menu"
^ false!

----- Method: AtomMorph>>bounceIn: (in category 'private') -----
bounceIn: aRect
"Move this atom one step along its velocity vector and make it bounce if it goes outside the given rectangle. Return true if it is bounced."

| p vx vy px py bounced |
p := self position.
vx := velocity x. vy := velocity y.
px := p x + vx. py := p y + vy.
bounced := false.
px > aRect right ifTrue: [
px := aRect right - (px - aRect right).
vx := velocity x negated.
bounced := true].
py > aRect bottom ifTrue: [
py := aRect bottom - (py - aRect bottom).
vy := velocity y negated.
bounced := true].
px < aRect left ifTrue: [
px := aRect left - (px - aRect left).
vx := velocity x negated.
bounced := true].
py < aRect top ifTrue: [
py := aRect top - (py - aRect top).
vy := velocity y negated.
bounced := true].
self position: px @ py.
bounced ifTrue: [self velocity: vx @ vy].
^ bounced
!

----- Method: AtomMorph>>defaultBorderWidth (in category 'initialization') -----
defaultBorderWidth
"answer the default border width for the receiver"
^ 0!

----- Method: AtomMorph>>defaultColor (in category 'initialization') -----
defaultColor
"answer the default color/fill style for the receiver"
^ Color blue!

----- Method: AtomMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
"Note: Set 'drawAsRect' to true to make the atoms draw faster. When testing the speed of other aspects of Morphic, such as its damage handling efficiency for large numbers of atoms, it is useful to make drawing faster."

| drawAsRect |
drawAsRect := false. "rectangles are faster to draw"
drawAsRect
ifTrue: [aCanvas fillRectangle: self bounds color: color]
ifFalse: [super drawOn: aCanvas].!

----- Method: AtomMorph>>infected (in category 'accessing') -----
infected

^ color = Color red!

----- Method: AtomMorph>>infected: (in category 'accessing') -----
infected: aBoolean

aBoolean
ifTrue: [self color: Color red]
ifFalse: [self color: Color blue].!

----- Method: AtomMorph>>initialize (in category 'initialization') -----
initialize
"Make a new atom with a random position and velocity."
super initialize.
""
self extent: 8 @ 7.

self
randomPositionIn: (0 @ 0 corner: 300 @ 300)
maxVelocity: 10!

----- Method: AtomMorph>>randomPositionIn:maxVelocity: (in category 'initialization') -----
randomPositionIn: aRectangle maxVelocity: maxVelocity
"Give this atom a random position and velocity."

| origin extent |
origin := aRectangle origin.
extent := (aRectangle extent - self bounds extent) rounded.
self position:
(origin x + extent x atRandom) @
(origin y + extent y atRandom).
velocity :=
(maxVelocity - (2 * maxVelocity) atRandom) @
(maxVelocity - (2 * maxVelocity) atRandom).
!

----- Method: AtomMorph>>velocity (in category 'accessing') -----
velocity

^ velocity!

----- Method: AtomMorph>>velocity: (in category 'accessing') -----
velocity: newVelocity

velocity := newVelocity.!

EllipseMorph subclass: #Flasher
instanceVariableNames: 'onColor'
classVariableNames: ''
poolDictionaries: ''
category: 'MorphicExtras-Demo'!

!Flasher commentStamp: '<historical>' prior: 0!
A simple example - a circle that flashes.

The "onColor" instance variable indicates the color to use when "on", A darker color is used to represent "off".

The #step method, called every 500ms. by default, alternatively makes the flasher show its "on" and its "off" color.!

----- Method: Flasher class>>descriptionForPartsBin (in category 'parts bin') -----
descriptionForPartsBin
"Answer a description of the receiver for use in a parts bin"

^ self partName: 'Flasher'
categories: #('Demo')
documentation: 'A circle that flashes'!

----- Method: Flasher>>initializeToStandAlone (in category 'parts bin') -----
initializeToStandAlone
"Initialize the flasher."

super initializeToStandAlone.
self color: Color red.
self onColor: Color red.
self borderWidth: 2.
self extent: 25@25!

----- Method: Flasher>>onColor (in category 'operations') -----
onColor
"Answer my onColor"

^ onColor ifNil: [onColor := Color red]!

----- Method: Flasher>>onColor: (in category 'operations') -----
onColor: aColor
"Change my on color to be aColor"

onColor := aColor.
self color: aColor!

----- Method: Flasher>>step (in category 'stepping and presenter') -----
step
"Perform my standard periodic action"

super step.
self color = self onColor
ifTrue: [self color: (onColor alphaMixed: 0.5 with: Color black)]
ifFalse: [self color: onColor]!

----- Method: Flasher>>stepTime (in category 'testing') -----
stepTime
"Answer the desired time between steps, in milliseconds."

^ 500!