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

commits at source.squeak.org commits at source.squeak.org
Tue Sep 1 15:16:46 UTC 2009


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 at 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 at 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 at 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 at 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 at 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 at 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 at dw//2) extent: dw at 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 at delta y].
	delta y abs <= halfDW ifTrue: [delta := delta x at 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 at 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 at 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 at 0;
		extent: 100 at 100.
	tm := TransformationB2Morph new.
	tm setProperty: #rotationCenter toValue: 0 at 0.
	tm useRegularWarpBlt: usingBalloon not.
	self addMorph: tm.
	tm addMorph: innerPasteUp.
	tm beSticky.
	innerPasteUp beSticky.
	tm
		scale: 1.0;
		offset: 0 at 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 at 0 
		into: [ :min :each | min min: each position]) rounded.
	overlap = (0 at 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 at 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!




More information about the Squeak-dev mailing list