[comp.lang.smalltalk] Example r.4 application

kentb@argosy.UUCP (Kent Beck) (05/31/91)

Here is an old chestnut in a new fire.  For my first r.4 application
I ported a rope simulation.  Try it by executing "RopeSegment example".
Some interesting experiments to try are changing the color and size
for different segments, changing the simulation to make it more
rope-like, and making it go faster.  Thanks to Dave Liebs for his help.

Kent Beck
-------------snicker snack-------------
Wrapper subclass: #BufferedWrapper
	instanceVariableNames: 'pixmap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Rope'!
BufferedWrapper comment:
'I buffer my component to avoid flashing.  I cache a Pixmap in pixmap so one doesn''t need to be created every time I display.'!


!BufferedWrapper methodsFor: 'initialize-release'!

flushCaches
	pixmap := nil
	super flushCaches! !

!BufferedWrapper methodsFor: 'displaying'!

bufferContextFrom: aGraphicsContext 
	| context |
	self checkPixmap.
	context := pixmap graphicsContext.
	context paint: self backgroundColor.
	context displayRectangle: pixmap bounds.
	context capStyle: aGraphicsContext capStyle.
	context clientData: aGraphicsContext clientData.
	context clippingRectangle: aGraphicsContext clippingRectangleOrNil.
	context font: aGraphicsContext font.
	context joinStyle: aGraphicsContext joinStyle.
	context lineWidth: aGraphicsContext lineWidth.
	context paintPolicy: aGraphicsContext paintPolicy.
	context paint: aGraphicsContext paint.
	^context!

displayOn: aGraphicsContext 
	| context |
	context := self bufferContextFrom: aGraphicsContext.
	component displayOn: context.  "Side effects pixmap"
	pixmap displayOn: aGraphicsContext! !

!BufferedWrapper methodsFor: 'private'!

checkPixmap
	(pixmap isNil or: [pixmap extent ~= self bounds extent or: [pixmap isOpen not]])
		ifTrue: [pixmap := Pixmap extent: self bounds extent]!

invalidateRectangle: aRectangle repairNow: aBoolean forComponent: aVisualComponent
	"Propagate damage up the hierarchy after translating and clipping.
	Overridden to avoid flashing caused by blanking aRectangle before display."

	| gc |
	gc := self graphicsContext.
	gc clippingRectangle: (gc clippingBounds intersect: aRectangle).
	self displayOn: gc! !

Object subclass: #RopeSegment
	instanceVariableNames: 'previous next location '
	classVariableNames: 'FacadeForm '
	poolDictionaries: ''
	category: 'Graphics-Rope'!
RopeSegment comment:
'I am a member of a double linked list of segments, terminated by a RopeStart at one end and a RopeEnd at the other.  My location is a Point, which determines where I display and where I can be found for interaction.  I display using the toothpaste algorithm, which blackens circles along the rope and, trailing a ways behind, displays a white ball.  I simulate by moving to within a certain distance (cf. stretch) of my moving neighbor.'!


!RopeSegment methodsFor: 'accessing'!

extent
	^self facadeForm extent!

next: aRopeSegment
	next := aRopeSegment!

previous: aRopeSegment
	previous := aRopeSegment!

segmentAt: aPoint
	"Display is back to front, so search has to go backwards."

	| segment |
	(segment := next segmentAt: aPoint) notNil
		ifTrue: [^segment].
	^(self containsPoint: aPoint)
		ifTrue: [self]
		ifFalse: [nil]! !

!RopeSegment methodsFor: 'simulating'!

moveNextTowards: aPoint
	self moveTowards: aPoint.
	next moveNextTowards: location!

movePreviousTowards: aPoint
	self moveTowards: aPoint. 
	previous movePreviousTowards: location!

moveTo: aPoint
	"Be sure to propogate forwards first, because display will change 
	when change hits the RopeStart."

	location := aPoint rounded.
	next moveNextTowards: location. 
	previous movePreviousTowards: location.!

moveTowards: aPoint
	"Change the y calculation to (aPoint y + (delta y * self stretch // r) + 2)
	to get a gravity effect."

	| delta r |
	delta := location - aPoint.
	(r := delta x abs max: delta y abs) < self stretch ifTrue: [^self].
	location := aPoint x + (delta x * self stretch // r) 
		@ (aPoint y + (delta y * self stretch // r))

"This is the simpler, slower, all Float solution:
	| r theta |
	r := self stretch min: (location dist: aPoint).
	theta := (location - aPoint) theta.
	location := aPoint + (Point r: r theta: theta)"!

stretch
	"Make this 5 to get the rope effect, 10 to get a caterpillar, and 16 to get 
	a string of beads."

	^5! !

!RopeSegment methodsFor: 'displaying'!

displayBackgroundOn: aGraphicsContext
	aGraphicsContext 
		displayWedgeBoundedBy: (location extent: self extent) 
		startAngle: 0 
		sweepAngle: 360!

displayFacadeOn: aGraphicsContext
	self facadeForm 
		displayOn: aGraphicsContext 
		at: location!

displayOn: backgroundContext
	| queue foregroundContext |
	queue := OrderedCollection new.
	20 timesRepeat: [queue addLast: self].
	foregroundContext := backgroundContext copy.
	foregroundContext paint: ColorValue white.
	self displayOn: backgroundContext thenOn: foregroundContext queue: queue!

displayOn: backgroundContext thenOn: foregroundContext queue: aCollection
	self displayBackgroundOn: backgroundContext.
	aCollection removeFirst displayFacadeOn: foregroundContext.
	aCollection addLast: self.
	next 
		displayOn: backgroundContext 
		thenOn: foregroundContext 
		queue: aCollection!

facadeForm
	(FacadeForm notNil and: [FacadeForm isOpen]) ifTrue: [^FacadeForm].
	^FacadeForm := (Image 
		extent: 24@24 
		depth: 1 
		palette: CoveragePalette monoMaskPalette
		bits: #[0 0 0 0 0 0 0 0 0 16 0 0 2 74 0 0 0 209 0 0 7 228 128 0 9 253 32 0 3
250 0 0 11 246 160 0 17 251 0 0 10 200 128 0 0 86 32 0 11 72 128 0 16 42 0 0 2
160 0 0 0 4 128 0 4 72 0 0 0 32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 0 ]
		pad: 16) 
			asRetainedMedium! !

!RopeSegment methodsFor: 'testing'!

containsPoint: aPoint
	"Offset because the segment is displayed with its top left
	corner at location."

	^(location + (self extent // 2) dist: aPoint) < (self extent // 2)! !

!RopeSegment methodsFor: 'private'!

initialize
	location := 0@0! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RopeSegment class
	instanceVariableNames: ''!


!RopeSegment class methodsFor: 'instance creation'!

new
	^super new initialize!

new: anInteger
	| start |
	start := RopeStart new.
	start segment: (RopeEnd new).
	anInteger timesRepeat: [start insert: self new].
	^start! !

!RopeSegment class methodsFor: 'examples'!

example
	"RopeSegment example"

	(self new: 50) open! !

Model subclass: #RopeStart
	instanceVariableNames: 'segment '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Rope'!
RopeStart comment:
'I am the model for a rope.  I act as the base case for the recursive simulation methods by notifying my dependents.  My segment is a RopeSegment which is (potentially) one of many in a doubly linked list.'!


!RopeStart methodsFor: 'accessing'!

insert: aRopeSegment
	| oldSegment |
	oldSegment := segment.
	segment := aRopeSegment.
	oldSegment previous: aRopeSegment.
	aRopeSegment next: oldSegment.
	aRopeSegment previous: self!

segment: aRopeSegment
	segment := aRopeSegment!

segmentAt: aPoint
	^segment segmentAt: aPoint! !

!RopeStart methodsFor: 'simulating'!

movePreviousTowards: aPoint
	self changed! !

!RopeStart methodsFor: 'displaying'!

displayOn: aGraphicsContext
	segment displayOn: aGraphicsContext! !

!RopeStart methodsFor: 'user interface'!

open
	| topWindow topView |
	topWindow := ScheduledWindow new.
	topWindow model: self.
	topWindow label: 'Rope'.
	topView := CompositePart new.
	topWindow component: topView.
	topView add: (BorderedWrapper on: (BufferedWrapper on: (RopeView new model: self))).
	topWindow open! !

Model subclass: #RopeEnd
	instanceVariableNames: 'segment '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Rope'!
RopeEnd comment:
'I am the base case for the recursive methods in RopeSegment.'!


!RopeEnd methodsFor: 'accessing'!

previous: aRopeSegment!

segmentAt: aPoint
	^nil! !

!RopeEnd methodsFor: 'simulating'!

moveNextTowards: aPoint! !

!RopeEnd methodsFor: 'displaying'!

displayOn: backgroundContext thenOn: foregroundContext queue: aCollection
	[aCollection isEmpty] whileFalse:
		[aCollection removeFirst displayFacadeOn: foregroundContext]! !

ControllerWithMenu subclass: #RopeController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Rope'!
RopeController comment:
'I allow the user to grab a portion of the rope and drag it around.'!


!RopeController methodsFor: 'control defaults'!

redButtonActivity
	| segment previous next |
	segment := view segmentAt: sensor cursorPoint.
	segment isNil ifTrue: [^self].
	previous := self sensor cursorPoint.
	[sensor redButtonPressed] whileTrue:
		[next := self sensor cursorPoint.
		previous ~= next
			ifTrue: [segment moveTo: next.  previous := next].
		self poll]! !

View subclass: #RopeView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Rope'!
RopeView comment:
'I display a rope and find the selected segment.'!


!RopeView methodsFor: 'accessing'!

segmentAt: aPoint
	^model segmentAt: aPoint! !

!RopeView methodsFor: 'displaying'!

displayOn: aGraphicsContext
	model displayOn: aGraphicsContext! !

!RopeView methodsFor: 'controller accessing'!

defaultControllerClass
	^RopeController! !