'From Squeak 2.0 of May 22, 1998 on 22 May 1998 at 4:32:15 pm'!
Object subclass: #AbstractScoreEvent
	instanceVariableNames: 'time '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Music-Scores'!
!AbstractScoreEvent commentStamp: 'di 5/22/1998 16:32' prior: 0!
Abstract class for timed events in a MIDI score.
!


!AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:46'!
isNoteEvent

	^ false
! !

!AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:46'!
isTempoEvent

	^ false
! !

!AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:43'!
time

	^ time
! !

!AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:43'!
time: aNumber

	time _ aNumber.
! !
Object subclass: #AbstractSound
	instanceVariableNames: 'envelopes mSecsSinceStart samplesUntilNextControl scaledVol scaledVolIncr scaledVolLimit '
	classVariableNames: 'MaxScaledValue ScaleFactor Sounds '
	poolDictionaries: ''
	category: 'System-Sound'!

!AbstractSound methodsFor: 'initialization' stamp: 'jm 12/9/97 11:31'!
duration: seconds
	"Scale my envelopes to the given duration. Subclasses overriding this method should include a resend to super."

	envelopes do: [:e | e duration: seconds].
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 2/4/98 09:54'!
initialize

	envelopes _ #().
	mSecsSinceStart _ 0.
	samplesUntilNextControl _ 0.
	scaledVol _ (1.0 * ScaleFactor) rounded.
	scaledVolIncr _ 0.
	scaledVolLimit _ scaledVol.
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 1/31/98 16:09'!
setLoudness: vol
	"Initialize my volume envelopes and initial volume. Subclasses overriding this method should include a resend to super."

	envelopes do: [:e |
		(e isKindOf: VolumeEnvelope) ifTrue: [e scale: vol]].
	self initialVolume: vol.
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 1/31/98 15:26'!
setPitch: p dur: d loudness: l
	"Initialize my envelopes for the given parameters. Subclasses overriding this method should include a resend to super."

	envelopes do: [:e |
		(e isKindOf: VolumeEnvelope) ifTrue: [e scale: l].
		(e isKindOf: PitchEnvelope) ifTrue: [e centerPitch: p].
		e duration: d].
	self initialVolume: l.
	self duration: d.

! !


!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/17/97 22:23'!
addEnvelope: anEnvelope
	"Add the given envelope to my envelopes list."

	anEnvelope target: self.
	envelopes _ envelopes copyWith: anEnvelope.
! !

!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'!
envelopes
	"Return my collection of envelopes."

	^ envelopes
! !

!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'!
removeEnvelope: anEnvelope
	"Remove the given envelope from my envelopes list."

	envelopes _ envelopes copyWithout: anEnvelope.
! !


!AbstractSound methodsFor: 'volume' stamp: 'jm 2/4/98 06:49'!
adjustVolumeTo: vol overMSecs: mSecs
	"Adjust the volume of this sound to the given volume, a number in the range [0.0..1.0], over the given number of milliseconds. The volume will be changed a little bit on each sample until the desired volume is reached."

	| newScaledVol |
	newScaledVol _ (32768.0 * vol) truncated.
	newScaledVol = scaledVol ifTrue: [^ self].
	scaledVolLimit _ newScaledVol.
	scaledVolLimit > ScaleFactor ifTrue: [scaledVolLimit _ ScaleFactor].
	scaledVolLimit < 0 ifTrue: [scaledVolLimit _ 0].
	mSecs = 0
		ifTrue: [  "change immediately"
			scaledVol _ scaledVolLimit.
			scaledVolIncr _ 0]
		ifFalse: [
			scaledVolIncr _
				((scaledVolLimit - scaledVol) * 1000) // (self samplingRate * mSecs)].
! !

!AbstractSound methodsFor: 'volume' stamp: 'jm 12/17/97 17:39'!
initialVolume: vol
	"Set the initial volume of this sound to the given volume, a number in the range [0.0..1.0]."

	scaledVol _ (((vol asFloat min: 1.0) max: 0.0) * ScaleFactor) rounded.
	scaledVolLimit _ scaledVol.
	scaledVolIncr _ 0.
! !

!AbstractSound methodsFor: 'volume' stamp: 'di 1/31/98 15:55'!
loudness
	"Return a suitable volume for initing"

	^ scaledVol asFloat / ScaleFactor asFloat! !

!AbstractSound methodsFor: 'volume' stamp: 'jm 12/16/97 10:30'!
volumeEnvelopeScaledTo: scalePoint
	"Return a collection of values representing my volume envelope scaled by the given point. The scale point's x component is pixels/second and its y component is the number of pixels for full volume."

	| env amp vScale cnt oldT newT totalCnt |
	self error: 'not yet implemented'.

"old code:"
	totalCnt _ "initialCount" 1000.
	env _ Array new: (totalCnt * scalePoint x // self samplingRate min: 500).
	amp _ scaledVol asFloat / ScaleFactor.
	vScale _ scalePoint y asFloat / 1000.0.
	cnt _ totalCnt.
	oldT _ newT _ 0.  "Time in units of scale x per second"
	[cnt > 0 and: [newT <= env size]] whileTrue:
		[env atAll: (oldT+1 to: newT) put: (amp*vScale) asInteger.
		oldT _ newT.
		"amp _ amp * decayRate."
		cnt _ cnt - samplesUntilNextControl.
		newT _ totalCnt - cnt * scalePoint x // self samplingRate].
	env atAll: ((oldT+1 min: env size) to: env size) put: (amp*vScale) asInteger.
	^ env
! !


!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'!
computeSamplesForSeconds: seconds
	"Compute the samples of this sound without outputting them, and return the resulting buffer of samples."

	| buf |
	self reset.
	buf _ SoundBuffer newStereoSampleCount: (self samplingRate * seconds) asInteger.
	self playSampleCount: buf stereoSampleCount into: buf startingAt: 1.
	^ buf
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 8/24/97 20:48'!
pause
	"Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning."

	SoundPlayer pauseSound: self.! !

!AbstractSound methodsFor: 'playing'!
play
	"Play this sound to the sound ouput port in real time."

	SoundPlayer playSound: self.! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 12/9/97 10:46'!
playAndWaitUntilDone
	"Play this sound to the sound ouput port in real time."

	SoundPlayer playSound: self.
	[self samplesRemaining > 0] whileTrue.
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'!
playSampleCount: n into: aSoundBuffer startingAt: startIndex
	"Mixes the next count samples of this sound into the given buffer starting at the given index, updating the receiver's control parameters at periodic intervals."

	| fullVol samplesBetweenControlUpdates pastEnd i remainingSamples count |
	fullVol _ AbstractSound scaleFactor.
	samplesBetweenControlUpdates _ self samplingRate // self controlRate.
	pastEnd _ startIndex + n.  "index just index of after last sample"
	i _ startIndex.
	[i < pastEnd] whileTrue: [
		remainingSamples _ self samplesRemaining.
		remainingSamples <= 0 ifTrue: [^ self].
		count _ pastEnd - i.
		samplesUntilNextControl < count ifTrue: [count _ samplesUntilNextControl].
		remainingSamples < count ifTrue: [count _ remainingSamples].
		self mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: fullVol rightVol: fullVol.
		samplesUntilNextControl _ samplesUntilNextControl - count.
		samplesUntilNextControl <= 0 ifTrue: [
			self doControl.
			samplesUntilNextControl _ samplesBetweenControlUpdates].
		i _ i + count].
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'!
playSilently
	"Compute the samples of this sound without outputting them. Used for performance analysis."

	| buf |
	self reset.
	buf _ SoundBuffer newStereoSampleCount: (self samplingRate // 10).
	[self samplesRemaining > 0] whileTrue: [
		buf primFill: 0.
		self playSampleCount: buf stereoSampleCount into: buf startingAt: 1].
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:06'!
playSilentlyUntil: startTime
	"Compute the samples of this sound without outputting them. Used to fast foward to a particular starting time. The start time is given in seconds."

	| buf startSample nextSample samplesRemaining n |
	self reset.
	buf _ SoundBuffer newStereoSampleCount: (self samplingRate // 10).
	startSample _ (startTime * self samplingRate) asInteger.
	nextSample _ 1.
	[self samplesRemaining > 0] whileTrue: [
		nextSample >= startSample ifTrue: [^ self].
		samplesRemaining _ startSample - nextSample.
		samplesRemaining > buf stereoSampleCount
			ifTrue: [n _ buf stereoSampleCount]
			ifFalse: [n _ samplesRemaining].
		self playSampleCount: n into: buf startingAt: 1.
		nextSample _ nextSample + n].
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 3/4/98 13:16'!
resumePlaying
	"Resume playing this sound from where it last stopped."

	SoundPlayer resumePlaying: self.
! !


!AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 09:56'!
doControl
	"Update the control parameters of this sound using its envelopes, if any."
	"Note: This is only called at a small fraction of the sampling rate."

	| pitchModOrRatioChange |
	mSecsSinceStart _ mSecsSinceStart + (1000 // self controlRate).
	envelopes size > 0 ifTrue: [
		pitchModOrRatioChange _ false.
		1 to: envelopes size do: [:i |
			((envelopes at: i) updateTargetAt: mSecsSinceStart)
				ifTrue: [pitchModOrRatioChange _ true]].
		pitchModOrRatioChange ifTrue: [self internalizeModulationAndRatio]].
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 08:56'!
internalizeModulationAndRatio
	"Overridden by FMSound. This default implementation does nothing."
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 11/24/97 16:00'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1. The leftVol and rightVol parameters determine the volume of the sound in each channel, where 0 is silence and 1000 is full volume."

	self subclassResponsibility.
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 18:59'!
reset
	"Reset my internal state for a replay. Methods that override this method should do super reset."

	mSecsSinceStart _ 0.
	samplesUntilNextControl _ self samplingRate // self controlRate.
	envelopes size > 0 ifTrue: [
		1 to: envelopes size do: [:i | (envelopes at: i) reset]].
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'!
samplesRemaining
	"Answer the number of samples remaining until the end of this sound. A sound with an indefinite ending time should answer some large integer such as 1000000."

	^ 1000000
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 1/5/98 14:21'!
storeSample: sample in: aSoundBuffer at: sliceIndex leftVol: leftVol rightVol: rightVol
	"This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, this method is hand-inlined into all sound generation methods that use it."

	| i s |
		leftVol > 0 ifTrue: [
			i _ (2 * sliceIndex) - 1.
			s _ (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor).
			s >  32767 ifTrue: [s _  32767].  "clipping!!"
			s < -32767 ifTrue: [s _ -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
		rightVol > 0 ifTrue: [
			i _ 2 * sliceIndex.
			s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor).
			s >  32767 ifTrue: [s _  32767].  "clipping!!"
			s < -32767 ifTrue: [s _ -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'!
updateVolume
	"Increment the volume envelope of this sound. To avoid clicks, the volume envelope must be interpolated at the sampling rate, rather than just at the control rate like other envelopes. At the control rate, the volume envelope computes the slope and next target volume volume for the current segment of the envelope (i.e., it sets the rate of change for the volume parameter). When that target volume is reached, incrementing is stopped until a new increment is set."
	"This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, it is hand-inlined into all sound generation methods that use it."

		scaledVolIncr ~= 0 ifTrue: [
			scaledVol _ scaledVol + scaledVolIncr.
			((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
			 [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
				ifTrue: [  "reached the limit; stop incrementing"
					scaledVol _ scaledVolLimit.
					scaledVolIncr _ 0]].
! !


!AbstractSound methodsFor: 'composition'!
+ aSound
	"Return the mix of the receiver and the argument sound."

	^ MixedSound new
		add: self;
		add: aSound
! !

!AbstractSound methodsFor: 'composition'!
, aSound
	"Return the concatenation of the receiver and the argument sound."

	^ SequentialSound new
		add: self;
		add: aSound
! !

!AbstractSound methodsFor: 'composition' stamp: 'jm 12/17/97 18:00'!
delayedBy: seconds
	"Return a composite sound consisting of a rest for the given amount of time followed by the receiver."

	^ (RestSound dur: seconds), self
! !


!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/15/97 14:15'!
controlRate
	"Answer the number of control changes per second."

	^ 100
! !

!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/17/97 18:00'!
samplingRate
	"Answer the sampling rate in samples per second."

	^ SoundPlayer samplingRate
! !


!AbstractSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:15'!
copy
	"A sound should copy all of the state needed to play itself, allowing two copies of a sound to play at the same time. These semantics require a recursive copy but only down to the level of immutable data. For example, a SampledSound need not copy its sample buffer. Subclasses overriding this method should include a resend to super."

	^ self clone copyEnvelopes
! !

!AbstractSound methodsFor: 'copying' stamp: 'jm 12/17/97 22:22'!
copyEnvelopes
	"Private!! Support for copying. Copy my envelopes."

	envelopes _ envelopes collect: [:e | e copy target: self].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AbstractSound class
	instanceVariableNames: ''!

!AbstractSound class methodsFor: 'class initialization' stamp: 'di 2/2/98 14:39'!
initialize
	"AbstractSound initialize"
 
	ScaleFactor _ 2 raisedTo: 15.
	MaxScaledValue _ ((2 raisedTo: 31) // ScaleFactor) - 1.  "magnitude of largest scaled value in 32-bits"! !

!AbstractSound class methodsFor: 'class initialization' stamp: 'jm 1/5/98 13:51'!
scaleFactor

	^ ScaleFactor
! !


!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 1/5/98 17:40'!
default
	"Return a default sound prototype for this class, with envelopes if appropriate. (This is in contrast to new, which returns a raw instance without envelopes.)"

	^ self new
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:26'!
dur: d
	"Return a rest of the given duration."

	^ self basicNew setDur: d
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:26'!
new

	^ self basicNew initialize
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'di 1/30/98 14:28'!
noteSequenceOn: aSound from: anArray
	"Build a note sequence (i.e., a SequentialSound) from the given array using the given sound as the instrument. Elements are either (pitch, duration, loudness) triples or (#rest duration) pairs.  Pitches can be given as names or as numbers."
	| score pitch |
	score _ SequentialSound new.
	anArray do: [:el |
		el size = 3
			ifTrue: [
				pitch _ el at: 1.
				pitch isNumber ifFalse: [pitch _ self pitchForName: pitch].
				score add: (
					aSound copy
						setPitch: pitch
						dur: (el at: 2)
						loudness: (el at: 3) / 1000.0)]
			ifFalse: [
				score add: (RestSound dur: (el at: 2))]].
	^ score
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:27'!
pitch: p dur: d loudness: l
	"Return a new sound object for a note with the given parameters."

	^ self new setPitch: p dur: d loudness: l
! !

!AbstractSound class methodsFor: 'instance creation'!
pitchForName: aString
	"AbstractSound pitchForName: 'c2'"
	"#(c 'c#' d eb e f fs g 'g#' a bf b) collect: [ :s | AbstractSound pitchForName: s, '4']"

	| s modifier octave i j noteName p |
	s _ ReadStream on: aString.
	modifier _ $n.
	noteName _ s next.
	(s atEnd not and: [s peek isDigit]) ifFalse: [ modifier _ s next ].
	s atEnd
		ifTrue: [ octave _ 4 ]
		ifFalse: [ octave _ Integer readFrom: s ].
	octave < 0 ifTrue: [ self error: 'cannot use negative octave number' ].
	i _ 'cdefgab' indexOf: noteName.
	i = 0 ifTrue: [ self error: 'bad note name: ', noteName asString ].
	i _ #(2 4 6 7 9 11 13) at: i.
	j _ 's#fb' indexOf: modifier.
	j = 0 ifFalse: [ i _ i + (#(1 1 -1 -1) at: j) ].  "i is now in range: [1..14]"
	"Table generator: (1 to: 14) collect: [ :i | 16.3516 * (2.0 raisedTo: (i - 2) asFloat / 12.0)]"
	p _ #(15.4339 16.3516 17.3239 18.354 19.4454 20.6017 21.8268 23.1247 24.4997 25.9565 27.5 29.1352 30.8677 32.7032) at: i.
	octave timesRepeat: [ p _ 2.0 * p ].
	^ p
! !


!AbstractSound class methodsFor: 'examples' stamp: 'di 1/31/98 00:33'!
chromaticPitchesFrom: aPitch
	| pitch halfStep |
	pitch _ aPitch isNumber
			ifTrue: [aPitch]
			ifFalse: [self pitchForName: aPitch].
	halfStep _ self halfStep.
	pitch _ pitch / halfStep.
	^ (0 to: 14) collect: [:i | pitch _ pitch * halfStep]! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:35'!
chromaticScale
	"PluckedSound chromaticScale play"

	^ self chromaticScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:14'!
chromaticScaleOn: aSound
	"PluckedSound chromaticScale play"

	^ self noteSequenceOn: aSound
		from: (((self chromaticPitchesFrom: #c4) copyFrom: 1 to: 13)
			 collect: [:pitch | Array with: pitch with: 0.5 with: 300])
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/31/98 00:32'!
halfStep
	^ 2.0 raisedTo: 1.0/12.0! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'!
hiMajorScale
	"FMSound hiMajorScale play"

	^ self hiMajorScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'!
hiMajorScaleOn: aSound
	"FMSound hiMajorScale play"

	^ self majorScaleOn: aSound from: #c6! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'!
lowMajorScale
	"PluckedSound lowMajorScale play"

	^ self lowMajorScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:01'!
lowMajorScaleOn: aSound
	"PluckedSound lowMajorScale play"

	^ self majorScaleOn: aSound from: #c3! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:04'!
majorChord
	"FMSound majorChord play"
	^ self majorChordOn: self default from: #c4! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:25'!
majorChordOn: aSound from: aPitch
	"FMSound majorChord play"
	| score majorScale leadingRest pan note |
	majorScale _ self majorPitchesFrom: aPitch.
	score _ MixedSound new.
	leadingRest _ pan _ 0.
	#(1 3 5 8) do: [:noteIndex |
		note _ aSound copy
			setPitch: (majorScale at: noteIndex)
			dur: 2.0 - leadingRest
			loudness: 0.3.
		score add: (RestSound dur: leadingRest), note pan: pan.
		leadingRest _ leadingRest + 0.2.
		pan _ pan + 0.3].
	^ score
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 14:45'!
majorPitchesFrom: aPitch
	| chromatic |
	chromatic _ self chromaticPitchesFrom: aPitch.
	^ #(1 3 5 6 8 10 12 13 15 13 12 10 8 6 5 3 1) collect: [:i | chromatic at: i].
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:34'!
majorScale
	"FMSound majorScale play"

	^ self majorScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'!
majorScaleOn: aSound
	"FMSound majorScale play"

	^ self majorScaleOn: aSound from: #c5! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:14'!
majorScaleOn: aSound from: aPitch
	"FMSound majorScale play"

	^ self noteSequenceOn: aSound
		from: ((self majorPitchesFrom: aPitch)
			 collect: [:pitch | Array with: pitch with: 0.25 with: 300])
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:32'!
scaleTest
	"AbstractSound scaleTest play"

	^ MixedSound new
		add: FMSound majorScale pan: 0;
		add: (PluckedSound lowMajorScale delayedBy: 0.5) pan: 1.0.
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 12/17/97 21:25'!
testFMInteractively
	"Experiment with different settings of the FM modulation and multiplier settings interactively by moving the mouse. The top-left corner of the screen is 0 for both parameters. Stop when the mouse is pressed."
	"AbstractSound testFMInteractively"

	| s mousePt lastVal status mod mult |
	SoundPlayer startPlayerProcessBufferSize: 1100 rate: 11025 stereo: false.
	s _ FMSound pitch: 440.0 dur: 200.0 loudness: 0.2.

	SoundPlayer playSound: s.
	lastVal _ nil.
	[Sensor anyButtonPressed] whileFalse: [
		mousePt _ Sensor cursorPoint.
		mousePt ~= lastVal ifTrue: [
			mod _ mousePt x asFloat / 20.0.
			mult _ mousePt y asFloat / 20.0.
			s modulation: mod multiplier: mult.
			lastVal _ mousePt.
			status _
'mod: ', mod printString, '
mult: ', mult printString.
			status asParagraph displayOn: Display at: 10@10]].

	SoundPlayer shutDown.
! !


!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:38'!
bachFugue
	"Play a fugue by J. S. Bach using and instance of me as the sound for all four voices."
	"PluckedSound bachFugue play"

	^ self bachFugueOn: self default
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 18:27'!
bachFugueOn: aSound
	"Play a fugue by J. S. Bach using the given sound as the sound for all four voices."
	"PluckedSound bachFugue play"

	^ MixedSound new
		add: (self bachFugueVoice1On: aSound) pan: 1.0;
		add: (self bachFugueVoice2On: aSound) pan: 0.0;
		add: (self bachFugueVoice3On: aSound) pan: 1.0;
		add: (self bachFugueVoice4On: aSound) pan: 0.0.
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:51'!
bachFugueVoice1On: aSound
	"Voice one of a fugue by J. S. Bach."

	^ self noteSequenceOn: aSound from: #(
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(784  0.30 268)
		(831  0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(1175 0.30 268)
		(784  0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(1175 0.30 268)
		(698  0.15 268)
		(784  0.15 268)
		(831  0.60 268)
		(784  0.15 268)
		(698  0.15 268)
		(622  0.15 268)
		(1047 0.15 268)
		(988  0.15 268)
		(880  0.15 268)
		(784  0.15 268)
		(698  0.15 268)
		(622  0.15 268)
		(587  0.15 268)
		(523  0.30 268)
		(1245 0.30 268)
		(1175 0.30 268)
		(1047 0.30 268)
		(932  0.30 268)
		(880  0.30 268)
		(932  0.30 268)
		(1047 0.30 268)
		(740  0.30 268)
		(784  0.30 268)
		(880  0.30 268)
		(740  0.30 268)
		(784  0.60 268)
		(rest 0.15)
		(523  0.15 268)
		(587  0.15 268)
		(622  0.15 268)
		(698  0.15 268)
		(784  0.15 268)
		(831  0.45 268)
		(587  0.15 268)
		(622  0.15 268)
		(698  0.15 268)
		(784  0.15 268)
		(880  0.15 268)
		(932  0.45 268)
		(622  0.15 268)
		(698  0.15 268)
		(784  0.15 268)
		(831  0.15 268)
		(784  0.15 268)
		(698  0.15 268)
		(622  0.15 268)
		(587  0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.60 268)
		(rest 0.9)
		(1397 0.30 268)
		(1245 0.30 268)
		(1175 0.30 268)
		(rest 0.3)
		(831  0.30 268)
		(784  0.30 268)
		(698  0.30 268)
		(784  0.30 268)
		(698  0.15 268)
		(622  0.15 268)
		(698  0.30 268)
		(587  0.30 268)
		(784  0.60 268)
		(rest 0.3)
		(988  0.30 268)
		(1047 0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(784  0.30 268)
		(831  0.60 268)
		(rest 0.3)
		(880  0.30 268)
		(932  0.30 268)
		(932  0.15 268)
		(880  0.15 268)
		(932  0.30 268)
		(698  0.30 268)
		(784  0.60 268)
		(rest 0.3)
		(784  0.30 268)
		(831  0.30 268)
		(831  0.30 268)
		(784  0.30 268)
		(698  0.30 268)
		(rest 0.3)
		(415  0.30 268)
		(466  0.30 268)
		(523  0.30 268)
		(rest 0.3)
		(415  0.15 268)
		(392  0.15 268)
		(415  0.30 268)
		(349  0.30 268)
		(466  0.30 268)
		(523  0.30 268)
		(466  0.30 268)
		(415  0.30 268)
		(466  0.30 268)
		(392  0.30 268)
		(349  0.30 268)
		(311  0.30 268)
		(349  0.30 268)
		(554  0.30 268)
		(523  0.30 268)
		(466  0.30 268)
		(523  0.30 268)
		(415  0.30 268)
		(392  0.30 268)
		(349  0.30 268)
		(392  0.30 268)
		(784  0.15 268)
		(740  0.15 268)
		(784  0.30 268)
		(523  0.30 268)
		(622  0.30 268)
		(784  0.15 268)
		(740  0.15 268)
		(784  0.30 268)
		(880  0.30 268)
		(587  0.30 268)
		(784  0.15 268)
		(740  0.15 268)
		(784  0.30 268)
		(880  0.30 268)
		(523  0.15 268)
		(587  0.15 268)
		(622  0.60 268)
		(587  0.15 268)
		(523  0.15 268)
		(466  0.30 346)
		(rest 0.45)
		(587  0.15 346)
		(659  0.15 346)
		(740  0.15 346)
		(784  0.15 346)
		(880  0.15 346)
		(932  0.45 346)
		(659  0.15 346)
		(698  0.15 346)
		(784  0.15 346)
		(880  0.15 346)
		(932  0.15 346)
		(1047 0.45 346)
		(740  0.15 346)
		(784  0.15 346)
		(880  0.15 346)
		(932  0.30 346)
		(622  0.15 346)
		(587  0.15 346)
		(622  0.30 346)
		(392  0.30 346)
		(415  0.30 346)
		(698  0.15 346)
		(622  0.15 346)
		(698  0.30 346)
		(440  0.30 346)
		(466  0.30 346)
		(784  0.15 346)
		(698  0.15 346)
		(784  0.30 346)
		(494  0.30 346)
		(523  0.15 346)
		(698  0.15 346)
		(622  0.15 346)
		(587  0.15 346)
		(523  0.15 346)
		(466  0.15 346)
		(440  0.15 346)
		(392  0.15 346)
		(349  0.30 346)
		(831  0.30 346)
		(784  0.30 346)
		(698  0.30 346)
		(622  0.30 346)
		(587  0.30 346)
		(622  0.30 346)
		(698  0.30 346)
		(494  0.30 346)
		(523  0.30 346)
		(587  0.30 346)
		(494  0.30 346)
		(523  0.60 346)
		(rest 0.3)
		(659  0.30 346)
		(698  0.30 346)
		(698  0.15 346)
		(659  0.15 346)
		(698  0.30 346)
		(523  0.30 346)
		(587  0.60 346)
		(rest 0.3)
		(587  0.30 346)
		(622  0.30 346)
		(622  0.15 346)
		(587  0.15 346)
		(622  0.30 346)
		(466  0.30 346)
		(523  1.20 346)
		(523  0.30 346)
		(587  0.15 346)
		(622  0.15 346)
		(698  0.15 346)
		(622  0.15 346)
		(698  0.15 346)
		(587  0.15 346)
		(494  0.30 457)
		(rest 0.6)
		(494  0.30 457)
		(523  0.30 457)
		(rest 0.6)
		(622  0.30 457)
		(587  0.30 457)
		(rest 0.6)
		(698  0.60 457)
		(rest 0.6)
		(698  0.30 457)
		(622  0.30 457)
		(831  0.30 457)
		(784  0.30 457)
		(698  0.30 457)
		(622  0.30 457)
		(587  0.30 457)
		(622  0.30 457)
		(698  0.30 457)
		(494  0.30 457)
		(523  0.30 457)
		(587  0.30 457)
		(494  0.30 457)
		(494  0.30 457)
		(523  0.30 457)
		(rest 0.3)
		(523  0.30 457)
		(698  0.15 457)
		(587  0.15 457)
		(622  0.15 457)
		(523  0.45 457)
		(494  0.30 457)
		(523  0.60 457)
		(rest 0.3)
		(659  0.30 268)
		(698  0.60 268)
		(rest 0.3)
		(698  0.30 268)
		(698  0.30 268)
		(622  0.15 268)
		(587  0.15 268)
		(622  0.30 268)
		(698  0.30 268)
		(587  0.40 268)
		(rest 0.4)
		(587  0.40 268)
		(rest 0.4)
		(523  1.60 268)).! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'!
bachFugueVoice2On: aSound
	"Voice two of a fugue by J. S. Bach."

	^ self noteSequenceOn: aSound from: #(
		(rest 4.8)
		(1568 0.15 346)
		(1480 0.15 346)
		(1568 0.30 346)
		(1047 0.30 346)
		(1245 0.30 346)
		(1568 0.15 346)
		(1480 0.15 346)
		(1568 0.30 346)
		(1760 0.30 346)
		(1175 0.30 346)
		(1568 0.15 346)
		(1480 0.15 346)
		(1568 0.30 346)
		(1760 0.30 346)
		(1047 0.15 346)
		(1175 0.15 346)
		(1245 0.60 346)
		(1175 0.15 346)
		(1047 0.15 346)
		(932  0.30 346)
		(1245 0.15 346)
		(1175 0.15 346)
		(1245 0.30 346)
		(784  0.30 346)
		(831  0.30 346)
		(1397 0.15 346)
		(1245 0.15 346)
		(1397 0.30 346)
		(880  0.30 346)
		(932  0.30 346)
		(1568 0.15 346)
		(1397 0.15 346)
		(1568 0.30 346)
		(988  0.30 346)
		(1047 0.30 346)
		(1175 0.15 346)
		(1245 0.15 346)
		(1397 0.90 346)
		(1245 0.15 346)
		(1175 0.15 346)
		(1047 0.15 346)
		(932  0.15 346)
		(831  0.15 346)
		(784  0.15 346)
		(698  0.30 346)
		(1661 0.30 346)
		(1568 0.30 346)
		(1397 0.30 346)
		(1245 0.30 346)
		(1175 0.30 346)
		(1245 0.30 346)
		(1397 0.30 346)
		(988  0.30 346)
		(1047 0.30 346)
		(1175 0.30 346)
		(988  0.30 346)
		(1047 0.30 457)
		(1568 0.15 457)
		(1480 0.15 457)
		(1568 0.30 457)
		(1175 0.30 457)
		(1245 0.60 457)
		(rest 0.3)
		(1319 0.30 457)
		(1397 0.30 457)
		(1397 0.15 457)
		(1319 0.15 457)
		(1397 0.30 457)
		(1047 0.30 457)
		(1175 0.60 457)
		(rest 0.3)
		(1175 0.30 457)
		(1245 0.30 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.30 457)
		(932  0.30 457)
		(1047 0.30 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.30 457)
		(1397 0.30 457)
		(932  0.30 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.30 457)
		(1397 0.30 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.60 457)
		(932  0.15 457)
		(831  0.15 457)
		(784  0.15 457)
		(622  0.15 457)
		(698  0.15 457)
		(784  0.15 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.15 457)
		(1175 0.15 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1047 0.15 457)
		(1175 0.15 457)
		(1245 0.15 457)
		(1397 0.15 457)
		(1568 0.15 457)
		(1760 0.15 457)
		(1865 0.15 457)
		(698  0.15 457)
		(784  0.15 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.15 457)
		(1175 0.15 457)
		(1319 0.15 457)
		(1397 0.15 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.15 457)
		(1397 0.15 457)
		(1568 0.15 457)
		(1760 0.15 457)
		(1976 0.15 457)
		(2093 0.30 457)
		(1976 0.15 457)
		(1760 0.15 457)
		(1568 0.15 457)
		(1397 0.15 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1047 0.30 457)
		(1245 0.30 457)
		(1175 0.30 457)
		(1047 0.30 457)
		(932  0.30 457)
		(880  0.30 457)
		(932  0.30 457)
		(1047 0.30 457)
		(740  0.30 457)
		(784  0.30 457)
		(880  0.30 457)
		(740  0.30 457)
		(784  0.30 457)
		(1175 0.15 457)
		(1047 0.15 457)
		(1175 0.30 457)
		(rest 0.6)
		(1319 0.15 457)
		(1175 0.15 457)
		(1319 0.30 457)
		(rest 0.6)
		(1480 0.15 457)
		(1319 0.15 457)
		(1480 0.30 457)
		(rest 0.6)
		(784  0.15 457)
		(698  0.15 457)
		(784  0.30 457)
		(rest 0.6)
		(880  0.15 457)
		(784  0.15 457)
		(880  0.30 457)
		(rest 0.6)
		(988  0.15 457)
		(880  0.15 457)
		(988  0.30 457)
		(rest 0.6)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(784  0.30 457)
		(831  0.30 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(1175 0.30 457)
		(784  0.30 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(1175 0.30 457)
		(698  0.15 457)
		(784  0.15 457)
		(831  0.60 457)
		(784  0.15 457)
		(698  0.15 457)
		(622  0.30 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(784  0.30 457)
		(831  0.60 457)
		(rest 0.3)
		(880  0.30 457)
		(932  0.30 457)
		(932  0.15 457)
		(880  0.15 457)
		(932  0.30 457)
		(698  0.30 457)
		(784  0.60 457)
		(rest 0.3)
		(784  0.60 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.15 457)
		(831  0.15 457)
		(698  1.20 457)
		(698  0.30 591)
		(1175 0.15 591)
		(1047 0.15 591)
		(1175 0.30 591)
		(698  0.30 591)
		(622  0.30 591)
		(1245 0.15 591)
		(1175 0.15 591)
		(1245 0.30 591)
		(784  0.30 591)
		(698  0.30 591)
		(1397 0.15 591)
		(1245 0.15 591)
		(1397 0.30 591)
		(831  0.30 591)
		(784  0.15 591)
		(1397 0.15 591)
		(1245 0.15 591)
		(1175 0.15 591)
		(1047 0.15 591)
		(988  0.15 591)
		(880  0.15 591)
		(784  0.15 591)
		(1047 0.30 591)
		(1397 0.30 591)
		(1245 0.30 591)
		(1175 0.30 591)
		(rest 0.3)
		(831  0.30 591)
		(784  0.30 591)
		(698  0.30 591)
		(784  0.30 591)
		(698  0.15 591)
		(622  0.15 591)
		(698  0.30 591)
		(587  0.30 591)
		(831  0.30 591)
		(784  0.30 591)
		(rest 0.3)
		(880  0.30 591)
		(988  0.30 591)
		(1047 0.30 591)
		(698  0.15 591)
		(622  0.15 591)
		(587  0.15 591)
		(523  0.15 591)
		(523  0.30 591)
		(1047 0.15 346)
		(988  0.15 346)
		(1047 0.30 346)
		(784  0.30 346)
		(831  0.30 346)
		(1047 0.15 346)
		(988  0.15 346)
		(1047 0.30 346)
		(1175 0.30 346)
		(784  0.30 346)
		(1047 0.15 346)
		(988  0.15 346)
		(1047 0.30 346)
		(1175 0.30 346)
		(698  0.20 346)
		(784  0.20 346)
		(831  0.80 346)
		(784  0.20 346)
		(698  0.20 346)
		(659  1.60 346)).
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'!
bachFugueVoice3On: aSound
	"Voice three of a fugue by J. S. Bach."

	^ self noteSequenceOn: aSound from: #(
		(rest 14.4)
		(523  0.15 457)
		(494  0.15 457)
		(523  0.30 457)
		(392  0.30 457)
		(415  0.30 457)
		(523  0.15 457)
		(494  0.15 457)
		(523  0.30 457)
		(587  0.30 457)
		(392  0.30 457)
		(523  0.15 457)
		(494  0.15 457)
		(523  0.30 457)
		(587  0.30 457)
		(349  0.15 457)
		(392  0.15 457)
		(415  0.60 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(523  0.15 457)
		(494  0.15 457)
		(440  0.15 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(294  0.15 457)
		(311  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(208  0.15 457)
		(196  0.15 457)
		(175  0.15 457)
		(466  0.15 457)
		(415  0.15 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(262  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(208  0.15 457)
		(196  0.15 457)
		(175  0.15 457)
		(156  0.15 457)
		(415  0.15 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(277  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(208  0.30 457)
		(523  0.30 457)
		(466  0.30 457)
		(415  0.30 457)
		(392  0.30 457)
		(349  0.30 457)
		(392  0.30 457)
		(415  0.30 457)
		(294  0.30 457)
		(311  0.30 457)
		(349  0.30 457)
		(294  0.30 457)
		(311  0.30 457)
		(415  0.30 457)
		(392  0.30 457)
		(349  0.30 457)
		(392  0.30 457)
		(311  0.30 457)
		(294  0.30 457)
		(262  0.30 457)
		(294  0.30 457)
		(466  0.30 457)
		(415  0.30 457)
		(392  0.30 457)
		(415  0.30 457)
		(349  0.30 457)
		(311  0.30 457)
		(294  0.30 457)
		(311  0.30 457)
		(rest 1.2)
		(262  0.30 457)
		(233  0.30 457)
		(220  0.30 457)
		(rest 0.3)
		(311  0.30 457)
		(294  0.30 457)
		(262  0.30 457)
		(294  0.30 457)
		(262  0.15 457)
		(233  0.15 457)
		(262  0.30 457)
		(294  0.30 457)
		(196  0.30 591)
		(466  0.15 591)
		(440  0.15 591)
		(466  0.30 591)
		(294  0.30 591)
		(311  0.30 591)
		(523  0.15 591)
		(466  0.15 591)
		(523  0.30 591)
		(330  0.30 591)
		(349  0.30 591)
		(587  0.15 591)
		(523  0.15 591)
		(587  0.30 591)
		(370  0.30 591)
		(392  0.60 591)
		(rest 0.15)
		(196  0.15 591)
		(220  0.15 591)
		(247  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.45 591)
		(220  0.15 591)
		(233  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.15 591)
		(349  0.45 591)
		(247  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.30 591)
		(rest 0.6)
		(330  0.30 591)
		(349  0.30 591)
		(175  0.30 591)
		(156  0.30 591)
		(147  0.30 591)
		(rest 0.3)
		(208  0.30 591)
		(196  0.30 591)
		(175  0.30 591)
		(196  0.30 591)
		(175  0.15 591)
		(156  0.15 591)
		(175  0.30 591)
		(196  0.30 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(196  0.15 591)
		(175  0.15 591)
		(466  0.15 591)
		(415  0.15 591)
		(392  0.15 591)
		(349  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(196  0.15 591)
		(175  0.15 591)
		(156  0.15 591)
		(415  0.15 591)
		(392  0.15 591)
		(349  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(233  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(196  0.15 591)
		(175  0.15 591)
		(156  0.15 591)
		(147  0.15 591)
		(392  0.15 591)
		(349  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(247  0.15 591)
		(220  0.15 591)
		(196  0.60 772)
		(196  0.60 772)
		(rest 0.15)
		(196  0.15 772)
		(220  0.15 772)
		(247  0.15 772)
		(262  0.15 772)
		(294  0.15 772)
		(311  0.15 772)
		(349  0.15 772)
		(392  0.15 772)
		(349  0.15 772)
		(415  0.15 772)
		(392  0.15 772)
		(349  0.15 772)
		(311  0.15 772)
		(294  0.15 772)
		(262  0.15 772)
		(247  0.30 772)
		(262  0.15 772)
		(494  0.15 772)
		(262  0.30 772)
		(196  0.30 772)
		(208  0.30 772)
		(262  0.15 772)
		(247  0.15 772)
		(262  0.30 772)
		(294  0.30 772)
		(196  0.30 772)
		(262  0.15 772)
		(247  0.15 772)
		(262  0.30 772)
		(294  0.30 772)
		(175  0.15 772)
		(196  0.15 772)
		(208  0.60 772)
		(196  0.15 772)
		(175  0.15 772)
		(156  0.60 772)
		(rest 0.3)
		(311  0.30 772)
		(294  0.30 772)
		(262  0.30 772)
		(392  0.30 772)
		(196  0.30 772)
		(262  3.60 268)
		(494  0.40 268)
		(rest 0.4)
		(494  0.40 268)
		(rest 0.4)
		(392  1.60 268)).
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'!
bachFugueVoice4On: aSound
	"Voice four of a fugue by J. S. Bach."

	^ self noteSequenceOn: aSound from: #(
		(rest 61.2)
		(131  0.15 500)
		(123  0.15 500)
		(131  0.30 500)
		(98   0.30 500)
		(104  0.30 500)
		(131  0.15 500)
		(123  0.15 500)
		(131  0.30 500)
		(147  0.30 500)
		(98   0.30 500)
		(131  0.15 500)
		(123  0.15 500)
		(131  0.30 500)
		(147  0.30 500)
		(87   0.15 500)
		(98   0.15 500)
		(104  0.60 500)
		(98   0.15 500)
		(87   0.15 500)
		(78   0.60 500)
		(rest 0.3)
		(156  0.30 500)
		(147  0.30 500)
		(131  0.30 500)
		(196  0.30 500)
		(98   0.30 500)
		(131  3.60 268)
		(131  3.20 205)).
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:45'!
stereoBachFugue
	"Play fugue by J. S. Bach in stereo using different timbres."
	"AbstractSound stereoBachFugue play"

	"(AbstractSound bachFugueVoice1On: FMSound flute1) play"
	"(AbstractSound bachFugueVoice1On: PluckedSound default) play"

	^ MixedSound new
		add: (self bachFugueVoice1On: FMSound oboe1) pan: 0.2;
		add: (self bachFugueVoice2On: FMSound organ1) pan: 0.8;
		add: (self bachFugueVoice3On: PluckedSound default) pan: 0.4;
		add: (self bachFugueVoice4On: FMSound brass1) pan: 0.6.
! !


!AbstractSound class methodsFor: 'primitive generation' stamp: 'jm 1/21/98 17:08'!
cCodeForSoundPrimitives
	"Return a string containing the C code for the sound primitives. This string is pasted into a file, compiled, and linked into the virtual machine. Note that the virtual machine's primitive table must also be edited to make new primitives available."
	"AbstractSound cCodeForSoundPrimitives"

	^ CCodeGenerator new codeStringForPrimitives: #(
		(FMSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(PluckedSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(SampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(ReverbSound applyReverbTo:startingAt:count:)
	).
! !


!AbstractSound class methodsFor: 'sounds' stamp: 'di 1/27/98 15:12'!
initSounds  "AbstractSound initSounds"
	Sounds _ Dictionary new.
	(FMSound class organization listAtCategoryNamed: #instruments)
		do: [:soundName | Sounds at: soundName asString
						put: (FMSound perform: soundName)]! !

!AbstractSound class methodsFor: 'sounds' stamp: 'di 1/27/98 15:13'!
soundNamed: soundName
	^ Sounds at: soundName! !

!AbstractSound class methodsFor: 'sounds' stamp: 'jm 3/4/98 10:29'!
soundNamed: soundName ifAbsent: aBlock

	^ Sounds at: soundName ifAbsent: aBlock
! !

!AbstractSound class methodsFor: 'sounds' stamp: 'jm 5/16/1998 09:54'!
soundNamed: soundName put: aSound

	Sounds at: soundName put: aSound.
	Smalltalk at: #ScorePlayerMorph ifPresent: [:playerClass |
		playerClass allInstancesDo:
			[:player | player updateInstrumentsFromLibrary]].
! !

!AbstractSound class methodsFor: 'sounds' stamp: 'di 1/27/98 15:13'!
soundNames
	^ Sounds keys! !
FileDirectory subclass: #AcornFileDirectory
	instanceVariableNames: ''
	classVariableNames: 'FormsAreLittleEndian '
	poolDictionaries: ''
	category: 'System-Files'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AcornFileDirectory class
	instanceVariableNames: ''!

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 09:24'!
byteReverseForm: aForm
	"Byte-reverse the words of the given Form's bitmap. Supports porting a Squeak image to the Acorn."

	| bits w reversedW |
	bits _ aForm bits.
	1 to: bits size do: [:i |
		w _ bits at: i.
		reversedW _ Integer
			byte1: (w digitAt: 4)
			byte2: (w digitAt: 3)
			byte3: (w digitAt: 2)
			byte4: (w digitAt: 1).
		bits at: i put: reversedW].
! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 06:44'!
extensionDelimiter
	"Return the character used to delimit filename extensions. For the Acorn, use a slash, since that is what a dot gets converted to when loading files from foreign file systems."

	^ $/
! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 06:41'!
pathNameDelimiter

	^ $.
! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 09:25'!
platformSpecificStartup
	"Do platform-specific startup. This is a hook for starting up a default Squeak image on an Acorn, whose BitBlt expects Forms to have little-endian byte ordering."

	FormsAreLittleEndian ifNil: [FormsAreLittleEndian _ false].
	FormsAreLittleEndian ifTrue: [^ self].  "already converted"

	Form withAllSubclasses do: [:c |
		c allInstancesDo: [:f |
			"skip the Display, since it will be redrawn anyway"
			f == Display ifFalse: [self byteReverseForm: f]]].

	FormsAreLittleEndian _ true.
! !
SwikiAction subclass: #ActiveSwikiAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PluggableWebServer'!

!ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'ls 5/1/98 11:29'!
browse: pageRef from: request
	"Just reply with a page in HTML format"

	| formattedPage liveText|
	liveText _ HTMLformatter evalEmbedded: (pageRef text)
		with: request unlessContains: (self dangerSet).
	formattedPage _ pageRef copy.
	"Make a copy, then format the text."
	formattedPage formatted: (HTMLformatter swikify: liveText
			linkhandler: [:link | urlmap
					linkFor: link
					from: request peerName
					storingTo: OrderedCollection new]).
	request reply: ((self formatterFor: 'page') format: formattedPage).
! !

!ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'tk 2/4/98 12:52'!
dangerSet
	^#('Smalltalk' 'view' 'open' 'perform:' 'FileStream' 'FileDirectory' 'fileIn' 'Compiler' 'halt'
	'PWS' 'Swiki')
! !

!ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'tk 1/31/98 16:44'!
inputFrom: request
	"Take user's input and respond with a searchresult or store the edit"

	| coreRef page |
	coreRef _ request message size < 2
		ifTrue: ['1']
		ifFalse: [request message at: 2].
	coreRef = 'searchresult' ifTrue: [
		"If contains search string, do search"
		request reply: PWS crlf, 
			(HTMLformatter evalEmbedded: (self fileContents: source, 'results.html')
				with: (urlmap searchFor: (request fields at: 'searchFor' ifAbsent: ['nothing']))).
		^ #return].
	(request fields includesKey: 'text') ifTrue: ["It's a response from an edit, so store the page"
		page _ urlmap
			storeID: coreRef
			text: (request fields at: 'text' ifAbsent: ['blank text'])
			from: request peerName.
		page user: request userID.
		^ self].	"return self means do serve the edited page afterwards"
	"oops, a new kind!! -- but don't complain!! Could be for ActivePage!!"
"	Transcript show: 'Unknown data from client. '; show: request fields
printString; cr."! !
SketchMorph subclass: #ActorDroneMorph
	instanceVariableNames: 'running clan '
	classVariableNames: 'ClanCache OnTicksSelectorCache '
	poolDictionaries: ''
	category: 'Experimental-Miscellaneous'!
!ActorDroneMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
ActorDroneMorph comment:
'I am a class of ActorMorphs that all share the same behavior methods.  OnTicks defined for one of me is used for all of me as long as we are of the same clan.  Clan is a symbol that is our name.'!


!ActorDroneMorph methodsFor: 'all' stamp: 'tk 8/20/97 09:07'!
clan
	^ clan! !

!ActorDroneMorph methodsFor: 'all' stamp: 'sw 8/17/97 23:00'!
clan: aSymbol
	clan _ aSymbol! !

!ActorDroneMorph methodsFor: 'all' stamp: 'sw 8/17/97 22:59'!
nameInModel
	^ clan! !

!ActorDroneMorph methodsFor: 'all' stamp: 'tk 8/21/97 13:22'!
onTicksSelector
	"Cache the interned symbol.  Should intern: do this?"

	clan = ClanCache ifTrue: [^ OnTicksSelectorCache].
	ClanCache _ clan.
	^ OnTicksSelectorCache _ (self nameInModel, 'OnTicks:') asSymbol
! !

!ActorDroneMorph methodsFor: 'all' stamp: 'sw 8/18/97 13:41'!
step

	running ifTrue: [
		self world model perform: self onTicksSelector with: self].
! !

!ActorDroneMorph methodsFor: 'all' stamp: 'tk 8/27/97 23:46'!
stepTime

	^ 0! !
Object subclass: #ActorState
	instanceVariableNames: 'owningPlayer penDown penSize penColor fractionalPosition instantiatedUserScriptsDictionary '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting-Support'!
!ActorState commentStamp: 'di 5/22/1998 16:32' prior: 0!
Holds a record of data representing actor-like slots in the Morph, on behalf of an associated Player.  Presently also holds onto the scriptInstantion objects that represent active scripts in an instance, but this will probably change soon.!


!ActorState methodsFor: 'initialization' stamp: 'sw 4/30/1998 22:32'!
copyWithPlayerReferenceNilled
	"Answer a copy of the receiver in which all the items referring to the corresponding Player object are nilled out, for the purpose of being set up with fresh values, after the copy, by the caller"

	| holdPlayer holdScriptDict copy copyScriptDict |
	holdPlayer _ owningPlayer.
	owningPlayer _ nil.
	holdScriptDict _ self instantiatedUserScriptsDictionary.
	instantiatedUserScriptsDictionary _ nil.
	copy _ self deepCopy.
	owningPlayer _ holdPlayer.
	instantiatedUserScriptsDictionary _ holdScriptDict.
	holdScriptDict ifNotNil:
		[copyScriptDict _ IdentityDictionary new.
		holdScriptDict associationsDo:
			[:assoc |
				copyScriptDict add: (assoc key -> (assoc value copyWithPlayerObliterated))].
		copy instantiatedUserScriptsDictionary: copyScriptDict].
	^ copy
! !

!ActorState methodsFor: 'initialization' stamp: 'sw 5/13/1998 16:37'!
initializeFor: aPlayer
	| aNewDictionary |
	owningPlayer _ aPlayer.
	instantiatedUserScriptsDictionary ifNil: [^ self].
	aNewDictionary _ IdentityDictionary new.
	instantiatedUserScriptsDictionary associationsDo: 
		[:assoc |
			aNewDictionary at: assoc key put: (assoc value shallowCopy player: aPlayer)].
	instantiatedUserScriptsDictionary _ aNewDictionary.! !


!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:51'!
choosePenColor: evt
	evt hand changeColorTarget: owningPlayer costume selector: #penColor:.
! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:44'!
choosePenSize
	| menu sz |
	menu _ CustomMenu new.
	1 to: 10 do: [:w | menu add: w printString action: w].
	sz _ menu startUp.
	sz ifNotNil: [penSize _ sz]! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 15:16'!
defaultPenColor
	^ Color blue! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 15:03'!
defaultPenSize
	^ 1! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:35'!
getPenColor
	penColor ifNil: [penColor _ self defaultPenColor].
	^ penColor! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:40'!
getPenDown
	^ penDown == true! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:43'!
getPenSize
	penSize ifNil: [penSize _ self defaultPenSize].
	^ penSize! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 18:07'!
liftPen
	penDown _ false! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 14:58'!
lowerPen
	penDown _ true! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 18:03'!
penColor: aColor
	penColor _ aColor! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:51'!
setPenColor: aColor
	penColor _ aColor
! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:47'!
setPenDown: aBoolean
	penDown _ aBoolean! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:45'!
setPenSize: aNumber
	penSize _ aNumber! !


!ActorState methodsFor: 'position' stamp: 'jm 4/24/1998 21:34'!
fractionalPosition
	"Return my player's costume's position including the fractional part. This allows the precise position to be retained to avoid cummulative rounding errors, while letting Morphic do all its calculations with integer pixel coordinates. See the implementation of forward:."

	^ fractionalPosition
! !

!ActorState methodsFor: 'position' stamp: 'jm 4/24/1998 21:31'!
fractionalPosition: aPoint

	fractionalPosition _ aPoint asFloatPoint.
! !


!ActorState methodsFor: 'script instantiations' stamp: 'sw 4/9/98 22:35'!
instantiatedUserScriptsDictionary
	instantiatedUserScriptsDictionary ifNil: [instantiatedUserScriptsDictionary _ IdentityDictionary new].
	^ instantiatedUserScriptsDictionary! !

!ActorState methodsFor: 'script instantiations' stamp: 'sw 4/30/1998 21:51'!
instantiatedUserScriptsDictionary: aDict
	"Used for copying code only"
	instantiatedUserScriptsDictionary _ aDict! !


!ActorState methodsFor: 'other' stamp: 'sw 4/22/1998 17:02'!
addPlayerMenuItemsTo: aMenu hand: aHandMorph
	self getPenDown
		ifTrue: [aMenu add: 'pen up' action: #liftPen]
		ifFalse: [aMenu add: 'pen down' action: #lowerPen].
	aMenu add: 'pen size' action: #choosePenSize.
	aMenu add: 'pen color' action: #choosePenColor:.! !

!ActorState methodsFor: 'other' stamp: 'sw 4/13/1998 19:36'!
costume
	^ owningPlayer costume! !

!ActorState methodsFor: 'other' stamp: 'sw 5/12/1998 23:35'!
printOn: aStream
	aStream nextPutAll: 'ActorState for ', owningPlayer externalName, ' '.
	penDown ifNotNil: [aStream cr; nextPutAll: 'penDown ', penDown printString].
	penColor ifNotNil: [aStream cr; nextPutAll: 'penColor ', penColor printString].
	penSize ifNotNil: [aStream cr; nextPutAll: 'penSize ', penSize printString].
	instantiatedUserScriptsDictionary ifNotNil:
		[aStream cr; nextPutAll:
			'+ ', instantiatedUserScriptsDictionary size printString, ' user scripts'].
! !
RectangleMorph subclass: #AlignmentMorph
	instanceVariableNames: 'orientation centering hResizing vResizing inset minCellSize openToDragNDrop layoutNeeded '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!AlignmentMorph methodsFor: 'initialization' stamp: 'sw 9/10/97 14:47'!
initialize

	super initialize.
	borderWidth _ 0.
	orientation _ #horizontal.	"#horizontal or #vertical  or #free"
	centering _ #topLeft.		"#topLeft, #center, or #bottomRight"
	hResizing _ #spaceFill.		"#spaceFill, #shrinkWrap, or #rigid"
	vResizing _ #spaceFill.		"#spaceFill, #shrinkWrap, or #rigid"
	inset _ 2.					"pixels inset within owner's bounds"
	minCellSize _ 0.				"minimum space between morphs; useful for tables"
	openToDragNDrop _ false.	"objects can be dropped in or dragged out"
	layoutNeeded _ true.
	color _ Color r: 0.8 g: 1.0 b: 0.8.
! !


!AlignmentMorph methodsFor: 'classification' stamp: 'sw 5/13/1998 14:50'!
demandsBoolean
	"unique to the TEST frame inside a CompoundTileMorph"

	^ self hasProperty: #demandsBoolean! !

!AlignmentMorph methodsFor: 'classification' stamp: 'di 5/7/1998 01:20'!
isAlignmentMorph

	^ true
! !


!AlignmentMorph methodsFor: 'accessing'!
centering

	^ centering
! !

!AlignmentMorph methodsFor: 'accessing'!
centering: aSymbol
	"Set the minor dimension alignment to #topLeft, #center, or #bottomRight."

	centering _ aSymbol.
! !

!AlignmentMorph methodsFor: 'accessing' stamp: 'sw 2/13/98 16:15'!
chooseOrientation
	| aMenu emphases reply |
	emphases _ #(vertical horizontal).
	aMenu _ EmphasizedMenu selections: emphases.
	aMenu onlyBoldItem: (emphases indexOf: orientation).
	reply _ aMenu startUpWithCaption: 'Choose orientation'.
	(reply == nil or: [reply == orientation]) ifTrue: [^ self].
	self orientation: reply.
	self layoutChanged! !

!AlignmentMorph methodsFor: 'accessing' stamp: 'sw 10/19/97 23:39'!
configureForKids
	self openToDragNDrop: false.
	super configureForKids
! !

!AlignmentMorph methodsFor: 'accessing'!
hResizing

	^ hResizing
! !

!AlignmentMorph methodsFor: 'accessing'!
hResizing: aSymbol
	"Set the horizontal resizing style to #spaceFill, #shrinkWrap, or #rigid."

	hResizing _ aSymbol.
! !

!AlignmentMorph methodsFor: 'accessing'!
inset

	^ inset
! !

!AlignmentMorph methodsFor: 'accessing'!
inset: anInteger
	"Set the amount of padding within my bounds to the given amount."

	inset _ anInteger.
! !

!AlignmentMorph methodsFor: 'accessing'!
minCellSize

	^ minCellSize
! !

!AlignmentMorph methodsFor: 'accessing'!
minCellSize: anInteger
	"Set the minium space per submorph to the given size. Useful for making tables."

	minCellSize _ anInteger.
! !

!AlignmentMorph methodsFor: 'accessing'!
openCloseDragNDrop
	"Toggle this morph's ability to add and remove morphs via drag-n-drop."

	openToDragNDrop _ openToDragNDrop not.
! !

!AlignmentMorph methodsFor: 'accessing'!
openToDragNDrop

	^ openToDragNDrop
! !

!AlignmentMorph methodsFor: 'accessing'!
openToDragNDrop: aBoolean
	"Set this morph's ability to add and remove morphs via drag-n-drop."

	openToDragNDrop _ aBoolean.
! !

!AlignmentMorph methodsFor: 'accessing'!
orientation

	^ orientation
! !

!AlignmentMorph methodsFor: 'accessing' stamp: 'sw 9/10/97 14:55'!
orientation: aSymbol
	"Set the major layout dimension to #horizontal or #vertical or #free"

	orientation _ aSymbol.
! !

!AlignmentMorph methodsFor: 'accessing'!
vResizing

	^ vResizing
! !

!AlignmentMorph methodsFor: 'accessing'!
vResizing: aSymbol
	"Set the vertical resizing style to #spaceFill, #shrinkWrap, or #rigid."

	vResizing _ aSymbol.
! !


!AlignmentMorph methodsFor: 'geometry' stamp: 'jm 7/8/97 08:26'!
layoutChanged

	"invalidate old fullBounds in case we shrink"
	fullBounds ifNotNil: [self invalidRect: fullBounds].

	super layoutChanged.
	layoutNeeded _ true.
! !


!AlignmentMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:03'!
acceptDroppingMorph: aMorph event: evt
	"Allow the user to add submorphs just by dropping them on this morph."
	self privateAddMorph: aMorph atIndex: (self insertionIndexFor: aMorph).
	self changed.
	self layoutChanged.
! !

!AlignmentMorph methodsFor: 'dropping/grabbing'!
allowSubmorphExtraction

	^ openToDragNDrop
! !

!AlignmentMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:19'!
rootForGrabOf: aMorph

	| root |
	openToDragNDrop ifFalse: [^ super rootForGrabOf: aMorph].
	root _ aMorph.
	[root == self] whileFalse:
		[root owner = self ifTrue: [^ root].
		root _ root owner].
	^ super rootForGrabOf: aMorph
! !

!AlignmentMorph methodsFor: 'dropping/grabbing'!
wantsDroppedMorph: aMorph event: evt
	"Supports adding morphs by dropping."

	^ openToDragNDrop! !


!AlignmentMorph methodsFor: 'layout'!
fullBounds
	"This is the hook that triggers lazy re-layout of layout morphs. It works because layoutChanged clears the fullBounds cache. Once per cycle, the fullBounds is requested from every morph in the world, and that request gets propagated through the entire submorph hierarchy, causing re-layout where needed. Note that multiple layoutChanges to the same morph can be done with little cost, since the layout is only done when the morph needs to be displayed."

	fullBounds ifNil: [
		layoutNeeded ifTrue: [
			self resizeIfNeeded.
			self fixLayout.
			"compute fullBounds before calling changed to avoid infinite recursion"
			super fullBounds.  "updates cache"
			self changed.  "report change due to layout"
			layoutNeeded _ false]].
	^ super fullBounds
! !

!AlignmentMorph methodsFor: 'layout' stamp: 'sw 2/13/98 16:15'!
maxWidth
	"Return the minimum width for this morph."

	| spaceNeeded minW |
	hResizing = #rigid ifTrue: [^ self fullBounds width].
	submorphs isEmpty ifTrue: [^ self minWidthWhenEmpty].
	orientation == #horizontal ifTrue:
		[spaceNeeded _ 2 * (inset + borderWidth).
		submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minWidth max: minCellSize)]].
	orientation == #vertical ifTrue:
		[minW _ 0.
		submorphs do: [:m | minW _ minW max: m minWidth].
		spaceNeeded _ minW + (2 * (inset + borderWidth))].
	^ spaceNeeded! !

!AlignmentMorph methodsFor: 'layout' stamp: 'sw 2/13/98 16:15'!
minHeight
	"Return the minimum height for this morph."

	| minH spaceNeeded |
	vResizing = #rigid ifTrue: [^ self fullBounds height].
	submorphs isEmpty ifTrue: [^ self minHeightWhenEmpty].
	orientation == #horizontal ifTrue:
		[minH _ 0.
		submorphs do: [:m | minH _ minH max: m minHeight].
		spaceNeeded _ minH + (2 * (inset + borderWidth))].
	orientation == #vertical ifTrue:
		[spaceNeeded _ 2 * (inset + borderWidth).
		submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minHeight max: minCellSize)]].

	^ spaceNeeded
! !

!AlignmentMorph methodsFor: 'layout' stamp: 'jm 1/29/98 19:43'!
minHeightWhenEmpty

	^ 2
! !

!AlignmentMorph methodsFor: 'layout' stamp: 'sw 2/13/98 16:15'!
minWidth
	"Return the minimum width for this morph."

	| spaceNeeded minW |
	hResizing = #rigid ifTrue: [^ self fullBounds width].
	submorphs isEmpty ifTrue: [^ self minWidthWhenEmpty].
	orientation == #horizontal ifTrue:
		[spaceNeeded _ 2 * (inset + borderWidth).
		submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minWidth max: minCellSize)]].
	orientation == #vertical ifTrue:
		[minW _ 0.
		submorphs do: [:m | minW _ minW max: m minWidth].
		spaceNeeded _ minW + (2 * (inset + borderWidth))].
	^ spaceNeeded! !

!AlignmentMorph methodsFor: 'layout' stamp: 'jm 1/29/98 19:43'!
minWidthWhenEmpty

	^ 2
! !


!AlignmentMorph methodsFor: 'menu' stamp: 'sw 9/11/97 16:07'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'orientation...' action: #chooseOrientation.
	aCustomMenu add: (openToDragNDrop ifTrue: ['close'] ifFalse: ['open']) , ' dragNdrop'
			action: #openCloseDragNDrop.
! !


!AlignmentMorph methodsFor: 'private' stamp: 'di 5/7/1998 01:21'!
extraSpacePerMorph

	| spaceFillingMorphs spaceNeeded extra |
	spaceFillingMorphs _ 0.
	spaceNeeded _ 2 * (inset + borderWidth).
	orientation = #horizontal ifTrue: [
		submorphs do: [:m |
			spaceNeeded _ spaceNeeded + (m minWidth max: minCellSize).
			(m isAlignmentMorph and: [m hResizing = #spaceFill])
				ifTrue: [spaceFillingMorphs _ spaceFillingMorphs + 1]].
		extra _ (bounds width - spaceNeeded) max: 0.
	] ifFalse: [
		submorphs do: [:m |
			spaceNeeded _ spaceNeeded + (m minHeight max: minCellSize).
			(m isAlignmentMorph and: [m vResizing = #spaceFill])
				ifTrue: [spaceFillingMorphs _ spaceFillingMorphs + 1]].
		extra _ (bounds height - spaceNeeded) max: 0].

	(submorphs size <= 1 or: [spaceFillingMorphs <= 1]) ifTrue: [^ extra].
	^ extra // spaceFillingMorphs
! !

!AlignmentMorph methodsFor: 'private' stamp: 'sw 2/13/98 16:15'!
fixLayout

	| extraPerMorph nextPlace space |
	extraPerMorph _ self extraSpacePerMorph.
	orientation = #horizontal
		ifTrue: [nextPlace _ bounds left + inset + borderWidth]
		ifFalse: [nextPlace _ bounds top + inset + borderWidth].
	submorphs do: [:m |
		space _ self placeAndSize: m at: nextPlace padding: extraPerMorph.
		nextPlace _ nextPlace + space].
! !

!AlignmentMorph methodsFor: 'private' stamp: 'sw 9/10/97 14:54'!
insertionIndexFor: aMorph
	"Return the index at which the given morph should be inserted into the submorphs of the receiver."

	| newCenter |
	newCenter _ aMorph fullBounds center.
	orientation == #horizontal ifTrue:
		[submorphs doWithIndex: [:m :i |
			newCenter x < m fullBounds center x ifTrue: [^ i]]].
	orientation == #vertical ifTrue:
		[submorphs doWithIndex: [:m :i |
			newCenter y < m fullBounds center y ifTrue: [^ i]]].

	^ submorphs size + 1  "insert after the last submorph"
! !

!AlignmentMorph methodsFor: 'private'!
layoutInWidth: w height: h
	"Adjust the size of the receiver in its space-filling dimensions during layout. This message is sent to only to layout submorphs."

	((hResizing = #spaceFill) and: [bounds width ~= w]) ifTrue: [
		bounds _ bounds origin extent: (w @ bounds height).
		fullBounds _ nil.
		layoutNeeded _ true].

	((vResizing = #spaceFill) and: [bounds height ~= h]) ifTrue: [
		bounds _ bounds origin extent: (bounds width @ h).
		fullBounds _ nil.
		layoutNeeded _ true].
! !

!AlignmentMorph methodsFor: 'private' stamp: 'di 5/7/1998 01:21'!
placeAndSize: m at: nextPlace padding: padding

	| space totalInset fullBnds left top |
	totalInset _ inset + borderWidth.
	orientation = #horizontal ifTrue: [
		space _ m minWidth max: minCellSize.
		m isAlignmentMorph ifTrue: [
			(m hResizing = #spaceFill) ifTrue: [space _ space + padding].
			m layoutInWidth: space height: (bounds height - (2 * totalInset))].
	] ifFalse: [
		space _ m minHeight max: minCellSize.
		m isAlignmentMorph ifTrue: [
			(m vResizing = #spaceFill) ifTrue: [space _ space + padding].
			m layoutInWidth: (bounds width - (2 * totalInset)) height: space]].

	fullBnds _ m fullBounds.
	orientation = #horizontal ifTrue: [
		left _ nextPlace.
		centering = #topLeft
			ifTrue: [top _ bounds top + totalInset].
		centering = #bottomRight
			ifTrue: [top _ bounds bottom - totalInset - fullBnds height].
		centering = #center
			ifTrue: [top _ bounds top + ((bounds height - fullBnds height) // 2)].
	] ifFalse: [
		top _ nextPlace.
		centering = #topLeft
			ifTrue: [left _ bounds left + totalInset].
		centering = #bottomRight
			ifTrue: [left _ bounds right - totalInset - fullBnds width].
		centering = #center
			ifTrue: [left _ bounds left + ((bounds width - fullBnds width) // 2)]].

	m position: (left + (m bounds left - fullBnds left)) @ (top + (m bounds top - fullBnds top)).
	^ space
! !

!AlignmentMorph methodsFor: 'private' stamp: 'di 5/7/1998 01:21'!
resizeIfNeeded
	"Resize this morph if it is space-filling or shrink-wrap and its owner is not a layout morph."

	| newWidth newHeight |
	newWidth _ bounds width.
	newHeight _ bounds height.

	(owner == nil or: [owner isAlignmentMorph not]) ifTrue: [
		"if spaceFill and not in a LayoutMorph, grow to enclose submorphs"
		hResizing = #spaceFill ifTrue: [newWidth _ self minWidth max: self bounds width].
		vResizing = #spaceFill ifTrue: [newHeight _ self minHeight max: self bounds height]].

	"if shrinkWrap, adjust size to just fit around submorphs"
	hResizing = #shrinkWrap ifTrue: [newWidth _ self minWidth].
	vResizing = #shrinkWrap ifTrue: [newHeight _ self minHeight].

	((newWidth ~= bounds width) or: [newHeight ~= bounds height]) ifTrue: [
		"bounds really changed; flush fullBounds cache and fix submorph layouts"
		bounds _ bounds origin extent: newWidth@newHeight.
		fullBounds _ nil].
! !

!AlignmentMorph methodsFor: 'private' stamp: 'sw 5/6/1998 15:58'!
wantsKeyboardFocusFor: aSubmorph
	aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true].
	^ super wantsKeyboardFocusFor: aSubmorph! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AlignmentMorph class
	instanceVariableNames: ''!

!AlignmentMorph class methodsFor: 'instance creation'!
newColumn

	^ self new
		orientation: #vertical;
		hResizing: #spaceFill;
		vResizing: #spaceFill
! !

!AlignmentMorph class methodsFor: 'instance creation'!
newRow

	^ self new
		orientation: #horizontal;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		borderWidth: 0
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 12:18'!
newSpacer: aColor
	"Answer a space-filling instance of me of the given color."

	^ self new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		inset: 0;
		borderWidth: 0;
		color: aColor.
! !
Path subclass: #Arc
	instanceVariableNames: 'quadrant radius center '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Paths'!
!Arc commentStamp: 'di 5/22/1998 16:32' prior: 0!
Arc comment:
'Arcs are an unusual implementation of splines
due to Ted Kaehler.  Imagine two lines that meet at a corner.
Now imagine two moving points; one moves from the corner to
the end on one line, the other moves from the end of the other
line in to the corner.  Now imagine a series of lines drawn 
between those moving points at each step along the way (they
form a sort of spider web pattern).  By connecting segments
of the intersecting lines, a smooth curve is achieved that is
tangent to both of the original lines.  Voila.'!


!Arc methodsFor: 'accessing'!
center
	"Answer the point at the center of the receiver."

	^center! !

!Arc methodsFor: 'accessing'!
center: aPoint 
	"Set aPoint to be the receiver's center."

	center _ aPoint! !

!Arc methodsFor: 'accessing'!
center: aPoint radius: anInteger 
	"The receiver is defined by a point at the center and a radius. The 
	quadrant is not reset."

	center _ aPoint.
	radius _ anInteger! !

!Arc methodsFor: 'accessing'!
center: aPoint radius: anInteger quadrant: section 
	"Set the receiver's quadrant to be the argument, section. The size of the 
	receiver is defined by the center and its radius."

	center _ aPoint.
	radius _ anInteger.
	quadrant _ section! !

!Arc methodsFor: 'accessing'!
quadrant
	"Answer the part of the circle represented by the receiver."
	^quadrant! !

!Arc methodsFor: 'accessing'!
quadrant: section 
	"Set the part of the circle represented by the receiver to be the argument, 
	section."

	quadrant _ section! !

!Arc methodsFor: 'accessing'!
radius
	"Answer the receiver's radius."

	^radius! !

!Arc methodsFor: 'accessing'!
radius: anInteger 
	"Set the receiver's radius to be the argument, anInteger."

	radius _ anInteger! !


!Arc methodsFor: 'display box access'!
computeBoundingBox
	| aRectangle aPoint |
	aRectangle _ center - radius + form offset extent: form extent + (radius * 2) asPoint.
	aPoint _ center + form extent.
	quadrant = 1 ifTrue: [^ aRectangle encompass: center x @ aPoint y].
	quadrant = 2 ifTrue: [^ aRectangle encompass: aPoint x @ aPoint y].
	quadrant = 3 ifTrue: [^ aRectangle encompass: aPoint x @ center y].
	quadrant = 4 ifTrue: [^ aRectangle encompass: center x @ center y]! !


!Arc methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm

	| nSegments line angle sin cos xn yn xn1 yn1 |
	nSegments _ 12.0.
	line _ Line new.
	line form: self form.
	angle _ 90.0 / nSegments.
	sin _ (angle * (2 * Float pi / 360.0)) sin.
	cos _ (angle * (2 * Float pi / 360.0)) cos.
	quadrant = 1
		ifTrue: 
			[xn _ radius asFloat.
			yn _ 0.0].
	quadrant = 2
		ifTrue: 
			[xn _ 0.0.
			yn _ 0.0 - radius asFloat].
	quadrant = 3
		ifTrue: 
			[xn _ 0.0 - radius asFloat.
			yn _ 0.0].
	quadrant = 4
		ifTrue: 
			[xn _ 0.0.
			yn _ radius asFloat].
	nSegments asInteger
		timesRepeat: 
			[xn1 _ xn * cos + (yn * sin).
			yn1 _ yn * cos - (xn * sin).
			line beginPoint: center + (xn asInteger @ yn asInteger).
			line endPoint: center + (xn1 asInteger @ yn1 asInteger).
			line
				displayOn: aDisplayMedium
				at: aPoint
				clippingBox: clipRect
				rule: anInteger
				fillColor: aForm.
			xn _ xn1.
			yn _ yn1]! !

!Arc methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

	| newArc tempCenter |
	newArc _ Arc new.
	tempCenter _ aTransformation applyTo: self center.
	newArc center: tempCenter x asInteger @ tempCenter y asInteger.
	newArc quadrant: self quadrant.
	newArc radius: (self radius * aTransformation scale x) asInteger.
	newArc form: self form.
	newArc
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Arc class
	instanceVariableNames: ''!

!Arc class methodsFor: 'examples'!
example
	"Click the button somewhere on the screen. The designated point will
	be the center of an Arc with radius 50 in the 4th quadrant."

	| anArc aForm |
	aForm _ Form extent: 1 @ 30.	"make a long thin Form for display"
	aForm fillBlack.						"turn it black"
	anArc _ Arc new.
	anArc form: aForm.					"set the form for display"
	anArc radius: 50.0.
	anArc center: Sensor waitButton.
	anArc quadrant: 4.
	anArc displayOn: Display.
	Sensor waitButton

	"Arc example"! !
ArrayedCollection variableSubclass: #Array
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!Array commentStamp: 'di 5/22/1998 16:32' prior: 0!
Array comment:
'I present an ArrayedCollection whose elements are objects.'!


!Array methodsFor: 'comparing'!
hash
	"Make sure that equal (=) arrays hash equally."

	self size = 0 ifTrue: [^17171].
	^(self at: 1) hash + (self at: self size) hash! !

!Array methodsFor: 'comparing'!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	self size = 0 ifTrue: [^self hash].
	^(self first hashMappedBy: map) + (self last hashMappedBy: map)! !


!Array methodsFor: 'converting'!
asArray
	"Answer with the receiver itself."

	^self! !

!Array methodsFor: 'converting'!
elementsExchangeIdentityWith: otherArray
	<primitive: 128>
	self primitiveFailed! !

!Array methodsFor: 'converting'!
evalStrings
	   "Allows you to construct literal arrays.
    #(true false nil '5@6' 'Set new' '''text string''') evalStrings
    gives an array with true, false, nil, a Point, a Set, and a String
    instead of just a bunch of Symbols"
    | it |

    ^ self collect: [:each |
        it _ each.
        each == #true ifTrue: [it _ true].
		      each == #false ifTrue: [it _ false].
        each == #nil ifTrue: [it _ nil].
        each class == String ifTrue: [
			it _ Compiler evaluate: each].
        each class == Array ifTrue: [it _ it evalStrings].
        it]! !


!Array methodsFor: 'printing'!
isLiteral

	self detect: [:element | element isLiteral not] ifNone: [^true].
	^false! !

!Array methodsFor: 'printing' stamp: 'di 6/20/97 09:09'!
printOn: aStream
	aStream nextPut: $(.
	self do: [:element | element printOn: aStream. aStream space].
	aStream nextPut: $)! !

!Array methodsFor: 'printing'!
storeOn: aStream 
	"Use the literal form if possible."

	self isLiteral
		ifTrue: 
			[aStream nextPut: $#; nextPut: $(.
			self do: 
				[:element | 
				element printOn: aStream.
				aStream space].
			aStream nextPut: $)]
		ifFalse: [super storeOn: aStream]! !


!Array methodsFor: 'private' stamp: 'di 8/15/97 09:55'!
hasLiteralSuchThat: litBlock
	"Answer true if litBlock returns true for any literal in this array, even if imbedded in further array structure.  This method is only intended for private use by CompiledMethod hasLiteralSuchThat:"
	| lit |
	1 to: self size do:
		[:index | lit _ self at: index.
		(litBlock value: lit) ifTrue: [^ true].
		(lit class == Array and: [lit hasLiteralSuchThat: litBlock]) ifTrue: [^ true]].
	^false! !

!Array methodsFor: 'private'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !
ArrayedCollection subclass: #Array2D
	instanceVariableNames: 'width contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!

!Array2D methodsFor: 'access'!
at: i at: j
    "return the element"
    (i < 1) | (i > width) ifTrue: [
        ^ self error: 'first index out of bounds'].
    "second index bounds check is automatic, since contents
        array will get a bounds error."

    ^ contents at: (j - 1) * width + i! !

!Array2D methodsFor: 'access'!
at: i at: j add: value
    "add value to the element"
    | index |
    (i < 1) | (i > width) ifTrue: [
        ^ self error: 'first index out of bounds'].
    "second index bounds check is automatic, since contents
        array will get a bounds error."

    index _ (j - 1) * width + i.
    ^ contents at: index put: (contents at: index) + value! !

!Array2D methodsFor: 'access'!
at: i at: j put: value
    "return the element"
    (i < 1) | (i > width) ifTrue: [
        ^ self error: 'first index out of bounds'].
    "second index bounds check is automatic, since contents
        array will get a bounds error."

    ^ contents at: (j - 1) * width + i put: value! !

!Array2D methodsFor: 'access'!
atAllPut: value
    "Initialize"
    contents atAllPut: value! !

!Array2D methodsFor: 'access'!
atCol: i
    "Fetch a whole column.  6/20/96 tk"

	| ans |
	ans _ contents class new: self height.
    1 to: self height do: [:ind |
		ans at: ind put: (self at: i at: ind)].
	^ ans! !

!Array2D methodsFor: 'access'!
atCol: i put: list
    "Put in a whole column.
     hold first index constant"

    list size = self height ifFalse: [self error: 'wrong size'].
    list doWithIndex: [:value :j |
        self at: i at: j put: value].! !

!Array2D methodsFor: 'access'!
atRow: j
    "Fetch a whole row.  6/20/96 tk"

    ^ contents copyFrom: (j - 1) * width + 1 to: (j) * width! !

!Array2D methodsFor: 'access'!
atRow: j put: list
    "Put in a whole row.
     hold second index constant"

    list size = self width ifFalse: [self error: 'wrong size'].
    list doWithIndex: [:value :i |
        self at: i at: j put: value].! !

!Array2D methodsFor: 'access'!
do: aBlock
	"Iterate with X varying most quickly.  6/20/96 tk"
	^ contents do: aBlock! !

!Array2D methodsFor: 'access'!
extent
	^ width @ self height! !

!Array2D methodsFor: 'access'!
extent: extent fromArray: anArray
	"Load this 2-D array up from a 1-D array.  X varies most quickly.  6/20/96 tk"

	extent x * extent y = anArray size ifFalse: [
		^ self error: 'dimensions don''t match'].
	width _ extent x.
	contents _ anArray.! !

!Array2D methodsFor: 'access'!
height
    "second dimension"
    "no need to save it"
    ^ contents size // width! !

!Array2D methodsFor: 'access'!
width
    "first dimension"
    ^ width! !

!Array2D methodsFor: 'access'!
width: x height: y type: class
    "Set the number of elements in the first and
    second dimensions.  class can be Array or String or ByteArray."

    contents == nil ifFalse: [self error: 'No runtime size change yet'].
        "later move all the elements to the new sized array"
    width _ x.
    contents _ class new: width*y.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Array2D class
	instanceVariableNames: ''!

!Array2D class methodsFor: 'as yet unclassified'!
new
	"Override ArrayedCollection.  6/20/96 tk"
	^ self basicNew! !

!Array2D class methodsFor: 'as yet unclassified'!
new: size
	"Use (self new width: x height: y type: Array)   6/20/96 tk"
	^ self shouldNotImplement! !
SequenceableCollection subclass: #ArrayedCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Abstract'!
!ArrayedCollection commentStamp: 'di 5/22/1998 16:32' prior: 0!
ArrayedCollection comment:
'I am an abstract collection of elements with a fixed range of integers (from 1 to n>=1) as external keys.'!


!ArrayedCollection methodsFor: 'accessing'!
size
	"Primitive. Answer the number of indexable fields in the receiver. This
	value is the same as the largest legal subscript. Primitive is specified
	here to override SequenceableCollection size. Essential. See Object
	documentation whatIsAPrimitive. "

	<primitive: 62>
	^self basicSize! !


!ArrayedCollection methodsFor: 'adding'!
add: newObject

	self shouldNotImplement! !


!ArrayedCollection methodsFor: 'printing'!
storeOn: aStream

	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new: '.
	aStream store: self size.
	aStream nextPut: $).
	(self storeElementsFrom: 1 to: self size on: aStream)
		ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !


!ArrayedCollection methodsFor: 'private'!
defaultElement

	^nil! !

!ArrayedCollection methodsFor: 'private'!
fill: numElements fromStack: aContext 
	"Fill me with numElements elements, popped in reverse order from
	 the stack of aContext.  Do not call directly: this is called indirectly by {1. 2. 3}
	 constructs."

	aContext pop: numElements toIndexable: self! !

!ArrayedCollection methodsFor: 'private'!
storeElementsFrom: firstIndex to: lastIndex on: aStream

	| noneYet defaultElement arrayElement |
	noneYet _ true.
	defaultElement _ self defaultElement.
	firstIndex to: lastIndex do: 
		[:index | 
		arrayElement _ self at: index.
		arrayElement = defaultElement
			ifFalse: 
				[noneYet
					ifTrue: [noneYet _ false]
					ifFalse: [aStream nextPut: $;].
				aStream nextPutAll: ' at: '.
				aStream store: index.
				aStream nextPutAll: ' put: '.
				aStream store: arrayElement]].
	^noneYet! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ArrayedCollection class
	instanceVariableNames: ''!

!ArrayedCollection class methodsFor: 'instance creation'!
fromBraceStack: itsSize 
	"Answer an instance of me with itsSize elements, popped in reverse order from
	 the stack of thisContext sender.  Do not call directly: this is called by {1. 2. 3}
	 constructs."

	^ (self new: itsSize) fill: itsSize fromStack: thisContext sender! !

!ArrayedCollection class methodsFor: 'instance creation'!
new
	"Answer a new instance of me, with size = 0."

	^self new: 0! !

!ArrayedCollection class methodsFor: 'instance creation'!
new: size withAll: value 
	"Answer an instance of me, with number of elements equal to size, each 
	of which refers to the argument, value."

	^(self new: size) atAllPut: value! !

!ArrayedCollection class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."
	| newArray |
	newArray _ self new: aCollection size.
	1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)].
	^ newArray

"	Array newFrom: {1. 2. 3}
	{1. 2. 3} as: Array
	{1. 2. 3} as: ByteArray
	{$c. $h. $r} as: String
	{$c. $h. $r} as: Text
"! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: anObject 
	"Answer a new instance of me, containing only anObject."

	| newCollection |
	newCollection _ self new: 1.
	newCollection at: 1 put: anObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject 
	"Answer a new instance of me, containing firstObject and secondObject."

	| newCollection |
	newCollection _ self new: 2.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject 
	"Answer a new instance of me, containing only the three arguments as
	elements."

	| newCollection |
	newCollection _ self new: 3.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject with: fourthObject 
	"Answer a new instance of me, containing only the three arguments as
	elements."

	| newCollection |
	newCollection _ self new: 4.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	newCollection at: 4 put: fourthObject.
	^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject
	"Answer a new instance of me, containing only the five arguments as
	elements."

	| newCollection |
	newCollection _ self new: 5.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	newCollection at: 4 put: fourthObject.
	newCollection at: 5 put: fifthObject.
	^newCollection! !
ParseNode subclass: #AssignmentNode
	instanceVariableNames: 'variable value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!AssignmentNode commentStamp: 'di 5/22/1998 16:32' prior: 0!
AssignmentNode comment: 'I represent a (var_expr) construct.'!


!AssignmentNode methodsFor: 'initialize-release'!
toDoIncrement: var
	var = variable ifFalse: [^ nil].
	(value isMemberOf: MessageNode) 
		ifTrue: [^ value toDoIncrement: var]
		ifFalse: [^ nil]! !

!AssignmentNode methodsFor: 'initialize-release'!
value
	^ value! !

!AssignmentNode methodsFor: 'initialize-release'!
variable: aVariable value: expression

	variable _ aVariable.
	value _ expression! !

!AssignmentNode methodsFor: 'initialize-release'!
variable: aVariable value: expression from: encoder

	(aVariable isMemberOf: MessageNode)
		ifTrue: [^aVariable store: expression from: encoder].
	variable _ aVariable.
	value _ expression! !


!AssignmentNode methodsFor: 'code generation'!
emitForEffect: stack on: aStream

	value emitForValue: stack on: aStream.
	variable emitStorePop: stack on: aStream! !

!AssignmentNode methodsFor: 'code generation'!
emitForValue: stack on: aStream

	value emitForValue: stack on: aStream.
	variable emitStore: stack on: aStream! !

!AssignmentNode methodsFor: 'code generation'!
sizeForEffect: encoder

	^(value sizeForValue: encoder)
		+ (variable sizeForStorePop: encoder)! !

!AssignmentNode methodsFor: 'code generation'!
sizeForValue: encoder

	^(value sizeForValue: encoder)
		+ (variable sizeForStore: encoder)! !


!AssignmentNode methodsFor: 'printing'!
printOn: aStream indent: level

	variable printOn: aStream indent: level.
	aStream nextPutAll: ' _ '.
	value printOn: aStream indent: level + 2! !

!AssignmentNode methodsFor: 'printing'!
printOn: aStream indent: level precedence: p

	p < 4 ifTrue: [aStream nextPutAll: '('].
	self printOn: aStream indent: level.
	p < 4 ifTrue: [aStream nextPutAll: ')']! !


!AssignmentNode methodsFor: 'equation translation'!
variable
	^variable! !


!AssignmentNode methodsFor: 'C translation'!
asTranslatorNode
	^TAssignmentNode new
		setVariable: variable asTranslatorNode
		expression: value asTranslatorNode! !
TileMorph subclass: #AssignmentTileMorph
	instanceVariableNames: 'assignmentRoot assignmentSuffix dataType '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting-Tiles'!

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 12/12/97 01:24'!
arrowAction: delta
	| index aList |
	owner ifNil: [^ self].
	operatorOrExpression ifNotNil:
		[aList _ #(: Incr: Decr: Mult:).
		index _ aList indexOf: assignmentSuffix asSymbol.
		index  > 0 ifTrue:
			[self setAssignmentSuffix: (aList atWrap: index + delta).
			self acceptNewLiteral]]! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 5/2/1998 15:00'!
computeOperatorOrExpression
	| aSuffix |
	operatorOrExpression _ (assignmentRoot, assignmentSuffix) asSymbol.
	aSuffix _ ScriptingSystem wordingForAssignmentSuffix: assignmentSuffix.
	operatorReadoutString _ assignmentRoot, ' ', aSuffix.
 	self line1: operatorReadoutString.
	dataType == #number ifTrue: [self addArrows] ! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 11/17/97 14:36'!
initialize
	super initialize.
	type _ #operator.
	assignmentSuffix _ ':'! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 5/2/1998 15:00'!
setAssignmentSuffix: aString
	assignmentSuffix _ aString.
	self computeOperatorOrExpression.
	type _ #operator.
 	self line1: (ScriptingSystem wordingForOperator: operatorOrExpression).
	self addArrows; updateLiteralLabel! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 2/16/98 01:12'!
setRoot: aString dataType: aSymbol
	assignmentRoot _ aString.
	assignmentSuffix _ ':'.
	dataType _ aSymbol.
	self updateLiteralLabel! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 1/31/98 00:42'!
storeCodeOn: aStream
	aStream nextPutAll: ' assign', (assignmentSuffix copyWithout: $:), 'Getter: #'.
	aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot).
	aStream nextPutAll: ' setter: #'.
	aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot).
	aStream nextPutAll: ' amt: '! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 1/31/98 00:42'!
updateLiteralLabel
	self computeOperatorOrExpression.
	super updateLiteralLabel! !
LookupKey subclass: #Association
	instanceVariableNames: 'value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!Association commentStamp: 'di 5/22/1998 16:32' prior: 0!
Association comment:
'I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary.'!


!Association methodsFor: 'accessing'!
key: aKey value: anObject 
	"Store the arguments as the variables of the receiver."

	key _ aKey.
	value _ anObject! !

!Association methodsFor: 'accessing'!
value
	"Answer the value of the receiver."

	^value! !

!Association methodsFor: 'accessing'!
value: anObject 
	"Store the argument, anObject, as the value of the receiver."

	value _ anObject! !


!Association methodsFor: 'printing'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '->'.
	value printOn: aStream! !

!Association methodsFor: 'printing'!
storeOn: aStream
	"Store in the format (key->value)"
	aStream nextPut: $(.
	key storeOn: aStream.
	aStream nextPutAll: '->'.
	value storeOn: aStream.
	aStream nextPut: $)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Association class
	instanceVariableNames: ''!

!Association class methodsFor: 'instance creation'!
key: newKey value: newValue
	"Answer an instance of me with the arguments as the key and value of 
	the association."

	^(super key: newKey) value: newValue! !
EllipseMorph subclass: #AtomMorph
	instanceVariableNames: 'velocity '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!AtomMorph methodsFor: 'all'!
bounceIn: aRect
	| p vx vy px py |
	p _ self position.
	vx _ velocity x.  vy _ velocity y.
	px _ p x + vx.  py _ p y + vy.
	px > aRect right ifTrue: [
		px _ aRect right - (px - aRect right).
		vx _ velocity x negated.
	].
	py > aRect bottom ifTrue: [
		py _  aRect bottom - (py - aRect bottom).
		vy _ velocity y negated.
	].
	px < aRect left ifTrue: [
		px _ aRect left - (px - aRect left).
		vx _ velocity x negated.
	].
	py < aRect top ifTrue: [
		py _  aRect top - (py - aRect top).
		vy _ velocity y negated.
	].
	self position: px @ py.
	self velocity: vx @ vy.
! !

!AtomMorph methodsFor: 'all'!
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].! !

!AtomMorph methodsFor: 'all'!
infected

	^ color = Color red! !

!AtomMorph methodsFor: 'all'!
infected: aBoolean

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

!AtomMorph methodsFor: 'all'!
initialize
	"Make a new atom with a random position and velocity."

	super initialize.
	self extent: 8@7.
	self color: Color blue.
	self borderWidth: 0.
	self randomPositionIn: (0@0 corner: 300@300) maxVelocity: 10.
! !

!AtomMorph methodsFor: 'all'!
randomPositionIn: aRectangle maxVelocity: maxVelocity
	"Give this atom a random position and velocity."

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

!AtomMorph methodsFor: 'all'!
velocity

	^ velocity! !

!AtomMorph methodsFor: 'all'!
velocity: newVelocity

	velocity _ newVelocity.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AtomMorph class
	instanceVariableNames: ''!

!AtomMorph class methodsFor: 'all' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
EmbeddedServerAction subclass: #AuthorizedServerAction
	instanceVariableNames: 'authorizer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PluggableWebServer'!
!AuthorizedServerAction commentStamp: 'di 5/22/1998 16:32' prior: 0!
An EmbeddedServerAction that also has an Authorizer to verify username and password.!


!AuthorizedServerAction methodsFor: 'URL processing' stamp: 'mjg 11/17/97 11:20'!
authorizer
	^authorizer! !

!AuthorizedServerAction methodsFor: 'URL processing' stamp: 'mjg 11/17/97 11:20'!
authorizer: anAuthorizer
	authorizer _ anAuthorizer
! !

!AuthorizedServerAction methodsFor: 'URL processing' stamp: 'mjg 11/17/97 13:09'!
checkAuthorization: request
	^authorizer user: request userID.
! !

!AuthorizedServerAction methodsFor: 'URL processing' stamp: 'tk 5/21/1998 16:46'!
mapName: nameString password: pwdString to: aPerson
	"Insert/remove the username:password combination into/from the users Dictionary.  *** Use this method to add or delete users!!  If you ask for the authorizer and talk to it, the change will not be recorded on the disk!! ***   We use encoding per RFC1421."

	authorizer mapName: nameString password: pwdString to: aPerson.
	self authorizer: authorizer.	"force it to be written to the disk"
		"*** Authorizer not saved to disk yet for this class ***"! !
SwikiAction subclass: #AuthorizedSwikiAction
	instanceVariableNames: 'authorizer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PluggableWebServer'!
!AuthorizedSwikiAction commentStamp: 'di 5/22/1998 16:32' prior: 0!
A Server with a login name and password for the entire Swiki area.  Can be multiple users each with a different password.  Each sees and can modify the whole Swiki area.

To restart an existing Authorized Swiki:

	AuthorizedSwikiAction new restore: 'SWSecure'.

The front page URL is:  http://serverMachine:80/SWSecure.1

To make a completely new one:
	| a s |
	a := Authorizer new.
	a realm: 'SwikiArea'.
	a mapName: 'viki' password: 'hard2guess' to: 'viki'.
	AuthorizedSwikiAction setUp: 'SWSecure'.
	s := AuthorizedSwikiAction new restore: 'SWSecure'.
	s authorizer: a.
!


!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'rp 4/29/98 16:57'!
authorizer
	^authorizer! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 5/22/1998 07:46'!
authorizer: anAuthorizer
	"Smash all old name/password pairs with this new set.  Overwrites the file on the disk"

	| fName refStream |
	authorizer _ anAuthorizer.
	fName _ ServerAction serverDirectory, name, (ServerAction pathSeparator), 
				'authorizer'.
	refStream _ SmartRefStream fileNamed: fName.
	refStream nextPut: authorizer; close.
! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'rp 4/29/98 16:58'!
checkAuthorization: request
	^authorizer user: request userID.
! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 5/21/1998 16:30'!
mapName: nameString password: pwdString to: aPerson
	"Insert/remove the username:password combination into/from the users Dictionary.  *** Use this method to add or delete users!!  If you ask for the authorizer and talk to it, the change will not be recorded on the disk!! ***   We use encoding per RFC1421."

	authorizer mapName: nameString password: pwdString to: aPerson.
	self authorizer: authorizer.	"force it to be written to the disk"! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'rp 4/29/98 17:02'!
process: request
	self checkAuthorization: request.
	^(super process: request).! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 5/22/1998 10:21'!
restore: nameOfSwiki
	"Read all files in the directory 'nameOfSwiki'.  Reconstruct the url map."

	| fName |
	super restore: nameOfSwiki.
	fName _ ServerAction serverDirectory, name, (ServerAction pathSeparator), 
				'authorizer'.
	authorizer _ (FileStream oldFileNamed: fName) fileInObjectAndCode.
! !
Object subclass: #Authorizer
	instanceVariableNames: 'users realm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PluggableWebServer'!
!Authorizer commentStamp: 'di 5/22/1998 16:32' prior: 0!
The Authorizer does user authorization checking. Each instance of authorizer keeps track of the realm that it is authorizing for, and the table of authorized users. An authorizer can be asked to return the user name/symbol associated with a userID (which concatenates the username and password from the HTTP request) with the user: method.
!


!Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'!
realm
	^realm! !

!Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'!
realm: aString
	realm := aString
! !


!Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 13:01'!
encode: nameString password: pwdString
	"Encode per RFC1421 of the username:password combination."

	| clear code clearSize idx map |
	clear := (nameString, ':', pwdString) asByteArray.
	clearSize := clear size.
	[ clear size \\ 3 ~= 0 ] whileTrue: [ clear := clear, #(0) ].
	idx := 1.
	map := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'.
	code := WriteStream on: ''.
	[ idx < clear size ] whileTrue: [ code 
		nextPut: (map at: (clear at: idx) // 4 + 1);
		nextPut: (map at: (clear at: idx) \\ 4 * 16 + ((clear at: idx + 1) // 16) + 1);
   		nextPut: (map at: (clear at: idx + 1) \\ 16 * 4 + ((clear at: idx + 2) // 64) + 1);
   		nextPut: (map at: (clear at: idx + 2) \\ 64 + 1).
		idx := idx + 3 ].
	code := code contents.
	idx := code size.
	clear size - clearSize timesRepeat: [ code at: idx put: $=. idx := idx - 1].
	^code! !

!Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 12:31'!
mapFrom: aKey to: aPerson
	"Establish a mapping from a RFC 1421 key to a user."

	users isNil ifTrue: [ users := Dictionary new ].
	aPerson
	 isNil ifTrue: [ users removeKey: aKey ]
	 ifFalse: [
		users removeKey: (users keyAtValue: aPerson ifAbsent: []) ifAbsent: [].
		users at: aKey put: aPerson ]
! !

!Authorizer methodsFor: 'authentication' stamp: 'tk 5/21/1998 16:32'!
mapName: nameString password: pwdString to: aPerson
	"Insert/remove the encoding per RFC1421 of the username:password combination into/from the UserMap.  DO NOT call this directly, use mapName:password:to: in your ServerAction class.  Only it knows how to record the change on the disk!!"

	self mapFrom: (self encode: nameString password: pwdString) to: aPerson
! !

!Authorizer methodsFor: 'authentication' stamp: 'mjg 11/17/97 13:07'!
user: userId
	"Return the requesting user."
	^users at: userId ifAbsent: [ self error: (PWS unauthorizedFor: realm) ]! !
Morph subclass: #BackgroundMorph
	instanceVariableNames: 'image offset delta running '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!BackgroundMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
BackgroundMorph comment:
'This morph incorporates tiling and regular motion with the intent of supporting, eg, panning of endless (toroidal) backgrounds.

The idea is that embedded morphs get displayed at a moving offset relative to my position.  Moreover this display is tiled according to the bounding box of the submorphs (subBounds), as much as necesary to fill the rest of my bounds.'!


!BackgroundMorph methodsFor: 'all' stamp: 'di 11/4/97 09:01'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	running
		ifTrue: [aCustomMenu add: 'stop' action: #stopRunning]
		ifFalse: [aCustomMenu add: 'start' action: #startRunning].
! !

!BackgroundMorph methodsFor: 'all'!
drawOn: aCanvas
	"The tiling is solely determined by bounds, subBounds and offset.
	The extent of display is determined by bounds and the clipRect of the canvas."
	| start tileCanvas d subBnds |
	submorphs isEmpty ifTrue: [^ super drawOn: aCanvas].
	subBnds _ self subBounds.
	running ifFalse:
		[super drawOn: aCanvas.
		^ aCanvas fillRectangle: subBnds color: Color lightBlue].
	start _ subBnds topLeft + offset - bounds topLeft - (1@1) \\ subBnds extent - subBnds extent + (1@1).
	d _ subBnds topLeft - bounds topLeft.
"Sensor redButtonPressed ifTrue: [self halt]."
	start x to: bounds width - 1 by: subBnds width do:
		[:x |
		start y to: bounds height - 1 by: subBnds height do:
			[:y | tileCanvas _ aCanvas copyOffset: (x@y) - d clipRect: bounds.
			submorphs reverseDo: [:m | m fullDrawOn: tileCanvas]]]! !

!BackgroundMorph methodsFor: 'all'!
fullBounds
	^ self bounds! !

!BackgroundMorph methodsFor: 'all'!
fullDrawOn: aCanvas

	running ifFalse: [^ super fullDrawOn: (aCanvas copyClipRect: (bounds translateBy: aCanvas origin))].
	(aCanvas isVisible: bounds) ifTrue: [self drawOn: aCanvas].
! !

!BackgroundMorph methodsFor: 'all'!
initialize
	super initialize.
	offset _ 0@0.
	delta _ 1@0.
	running _ true! !

!BackgroundMorph methodsFor: 'all'!
layoutChanged
	"Do nothing, since I clip my submorphs"! !

!BackgroundMorph methodsFor: 'all'!
rootForGrabOf: aMorph
	"Be sticky."

	^ nil
! !

!BackgroundMorph methodsFor: 'all'!
slideBy: inc
	submorphs isEmpty ifTrue: [^ self].
	offset _ offset + inc \\ self subBounds extent.
	self changed! !

!BackgroundMorph methodsFor: 'all'!
startRunning
	running _ true.
	self changed! !

!BackgroundMorph methodsFor: 'all'!
step
	"Answer the desired time between steps in milliseconds."
	running ifTrue: [self slideBy: delta]! !

!BackgroundMorph methodsFor: 'all'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 20! !

!BackgroundMorph methodsFor: 'all'!
stopRunning
	running _ false.
	self changed! !

!BackgroundMorph methodsFor: 'all'!
subBounds
	"calculate the submorph bounds"
	| subBounds |
	subBounds _ nil.
	self submorphsDo:
		[:m | subBounds == nil
			ifTrue: [subBounds _ m fullBounds]
			ifFalse: [subBounds _ subBounds merge: m fullBounds]].
	^ subBounds! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BackgroundMorph class
	instanceVariableNames: ''!

!BackgroundMorph class methodsFor: 'all'!
test
	^ self new image: Form fromUser! !
Collection subclass: #Bag
	instanceVariableNames: 'contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!Bag commentStamp: 'di 5/22/1998 16:32' prior: 0!
Bag comment:
'I represent an unordered collection of possibly duplicate elements.
	
I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.'!


!Bag methodsFor: 'accessing'!
at: index

	self errorNotKeyed! !

!Bag methodsFor: 'accessing'!
at: index put: anObject

	self errorNotKeyed! !

!Bag methodsFor: 'accessing' stamp: 'di 9/11/97 16:14'!
cumulativeCounts
	"Answer with a collection of cumulative percents covered by elements so far."
	| s n |
	s _ self size // 100.0. n _ 0.
	^ self sortedCounts asArray collect:
		[:a | n _ n + a key. (n // s roundTo: 0.1) -> a value]! !

!Bag methodsFor: 'accessing'!
size

	| tally |
	tally _ 0.
	contents do: [:each | tally _ tally + each].
	^tally! !

!Bag methodsFor: 'accessing'!
sortedCounts
	"Answer with a collection of counts with elements, sorted by decreasing
	count."

	| counts |
	counts _ SortedCollection sortBlock: [:x :y | x >= y].
	contents associationsDo:
		[:assn |
		counts add: (Association key: assn value value: assn key)].
	^counts! !

!Bag methodsFor: 'accessing'!
sortedElements
	"Answer with a collection of elements with counts, sorted by element."

	| elements |
	elements _ SortedCollection new.
	contents associationsDo: [:assn | elements add: assn].
	^elements! !


!Bag methodsFor: 'testing'!
includes: anObject 
	"Refer to the comment in Collection|includes:."

	^contents includesKey: anObject! !

!Bag methodsFor: 'testing'!
occurrencesOf: anObject 
	"Refer to the comment in Collection|occurrencesOf:."

	(self includes: anObject)
		ifTrue: [^contents at: anObject]
		ifFalse: [^0]! !


!Bag methodsFor: 'adding'!
add: newObject 
	"Refer to the comment in Collection|add:."

	^self add: newObject withOccurrences: 1! !

!Bag methodsFor: 'adding'!
add: newObject withOccurrences: anInteger 
	"Add the element newObject to the receiver. Do so as though the element 
	were added anInteger number of times. Answer newObject."

	(self includes: newObject)
		ifTrue: [contents at: newObject put: anInteger + (contents at: newObject)]
		ifFalse: [contents at: newObject put: anInteger].
	^newObject! !


!Bag methodsFor: 'removing'!
remove: oldObject ifAbsent: exceptionBlock 
	"Refer to the comment in Collection|remove:ifAbsent:."

	| count |
	(self includes: oldObject)
		ifTrue: [(count _ contents at: oldObject) = 1
				ifTrue: [contents removeKey: oldObject]
				ifFalse: [contents at: oldObject put: count - 1]]
		ifFalse: [^exceptionBlock value].
	^oldObject! !


!Bag methodsFor: 'enumerating' stamp: 'SqR 11/4/97 19:58'!
asSet
	"Answer a set with the elements of the receiver"

	 ^contents keys! !

!Bag methodsFor: 'enumerating'!
do: aBlock 
	"Refer to the comment in Collection|do:."

	contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! !


!Bag methodsFor: 'private'!
setDictionary

	contents _ Dictionary new! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Bag class
	instanceVariableNames: ''!

!Bag class methodsFor: 'instance creation'!
new

	^super new setDictionary! !

!Bag class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	| newCollection |
	newCollection _ self new.
	newCollection addAll: aCollection.
	^newCollection

"	Bag newFrom: {1. 2. 3}
	{1. 2. 3} as: Bag
"! !
CurveMorph subclass: #BalloonMorph
	instanceVariableNames: 'target offsetFromTarget '
	classVariableNames: 'BalloonFont '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!BalloonMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
BalloonMorph comment:
'A balloon with text used for the display of explanatory information.

Balloon help is integrated into Morphic as follows:
If a Morph has the property #balloonText, then it will respond to #showBalloon by adding a text balloon to the world, and to #deleteBalloon by removing the balloon.

Moreover, if mouseOverEnabled is true (see class msg), then the Hand will arrange to cause display of the balloon after the mouse has lingered over the morph for a while, and removal of the balloon when the mouse leaves the bounds of that morph.  In any case, the Hand will attempt to remove any such balloons before handling mouseDown events, or displaying other balloons.'!


!BalloonMorph methodsFor: 'all' stamp: 'di 9/17/97 19:26'!
setTarget: aMorph
	target _ aMorph.
	offsetFromTarget _ self position - target position! !

!BalloonMorph methodsFor: 'all' stamp: 'di 9/17/97 19:27'!
step
	self position: target position + offsetFromTarget! !

!BalloonMorph methodsFor: 'all' stamp: 'di 9/18/97 10:10'!
stepTime
	^ 0  "every cycle"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BalloonMorph class
	instanceVariableNames: ''!

!BalloonMorph class methodsFor: 'all' stamp: 'di 10/20/97 20:10'!
chooseBalloonFont
	| sizes reply |
	sizes _ #(9 10 12 14).
	reply _ (SelectionMenu labelList: (sizes collect: [:s | s printString]) selections:  sizes) startUp.
	reply ifNotNil:
		[BalloonFont _ (TextStyle named: #ComicPlain) fontAt: (sizes indexOf: reply)]! !

!BalloonMorph class methodsFor: 'all' stamp: 'jm 5/20/1998 20:16'!
string: str for: morph corner: cornerName
	"Make up and return a balloon for morph.  Find the quadrant that
clips the text the least, using cornerName as a tie-breaker.  tk 9/12/97"

	| txt tm corners p1 p2 vertices c r maxArea aa verts mp dir mbc
 pref rectCorner morphPoint |
	BalloonFont
		ifNil: [txt _ str]
		ifNotNil: [txt _ Text string: str attribute: (TextFontReference toFont: BalloonFont)].
	tm _ (TextMorph new contents: txt) centered.

	"Construct vertices for a balloon below and to left of anchor"
	corners _ tm bounds corners atAll: #(1 4 3 2).
	p1 _ (corners at: 1) + ((0 - tm width//3)@0).
	p2 _ (corners at: 1) + ((0 - tm width//6)@(tm height//2)).
	vertices _ (Array with: p1 with: p2) , corners.
	r _ p1 rect: (corners at: 3).
	corners _ #(bottomRight bottomLeft topLeft topRight).
	pref _ corners indexOf: cornerName.
	c _ tm center.
	maxArea _ 0.
	(0 to: 3) do:
		[:i | "Try four rel locations of the balloon for greatest unclipped area"
		rectCorner _ corners atWrap: i+pref+2.
		morphPoint _ (#(bottomRight bottomLeft) includes: rectCorner)
						ifTrue: [#topCenter] ifFalse: [#bottomCenter].
		aa _ ((r align: (r perform: rectCorner)
				with: (mbc _ morph fullBoundsInWorld perform: morphPoint))
			intersect: (0@0 extent: morph world viewBox extent)) area.
		aa > maxArea ifTrue: [verts _ vertices.
							maxArea _ aa.
							mp _ mbc].
		dir _ (i+pref) odd ifTrue: [#horizontal] ifFalse: [#vertical].
		vertices _ vertices collect: [:p | p flipBy: dir centerAt: c]].
	^ self new color: (Color r: 1.0 g: 1.0 b: 0.6);
			setBorderWidth: 1 borderColor: Color black;
			setVertices: verts;
			addMorph: tm;
			align: verts first with: mp;
			setTarget: morph! !
Object subclass: #Base64MimeConverter
	instanceVariableNames: 'dataStream mimeStream data '
	classVariableNames: 'FromCharTable ToCharTable '
	poolDictionaries: ''
	category: 'Collections-Streams'!
!Base64MimeConverter commentStamp: 'di 5/22/1998 16:32' prior: 0!
This class encodes and decodes data in Base64 format.  This is MIME encoding.  We translate a whole stream at once, taking a Stream as input and giving one as output.  Returns a whole stream for the caller to use.
           0 A            17 R            34 i            51 z
           1 B            18 S            35 j            52 0
           2 C            19 T            36 k            53 1
           3 D            20 U            37 l            54 2
           4 E            21 V            38 m            55 3
           5 F            22 W            39 n            56 4
           6 G            23 X            40 o            57 5
           7 H            24 Y            41 p            58 6
           8 I            25 Z            42 q            59 7
           9 J            26 a            43 r            60 8
          10 K            27 b            44 s            61 9
          11 L            28 c            45 t            62 +
          12 M            29 d            46 u            63 /
          13 N            30 e            47 v
          14 O            31 f            48 w         (pad) =
          15 P            32 g            49 x
          16 Q            33 h            50 y
Outbound: bytes are broken into 6 bit chunks, and the 0-63 value is converted to a character.  3 data bytes go into 4 characters.
Inbound: Characters are translated in to 0-63 values and shifted into 8 bit bytes.

(See: N. Borenstein, Bellcore, N. Freed, Innosoft, Network Working Group, Request for Comments: RFC 1521, September 1993, MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies. Sec 6.2)

By Ted Kaehler, based on Tim Olson's Base64Filter.!


!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:55'!
dataStream
	^dataStream! !

!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'!
dataStream: anObject
	dataStream _ anObject! !

!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:53'!
mimeStream
	^mimeStream! !

!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'!
mimeStream: anObject
	mimeStream _ anObject! !


!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:34'!
mimeDecode
	"Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full byte stream of characters.  Reutrn a whole stream for the user to read."

	| nibA nibB nibC nibD |
	[mimeStream atEnd] whileFalse: [
		(nibA _ self nextValue) ifNil: [^ dataStream].
		(nibB _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)) asCharacter.
		nibB _ nibB bitAnd: 16rF.
		(nibC _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)) asCharacter.
		nibC _ nibC bitAnd: 16r3.
		(nibD _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibC bitShift: 6) + nibD) asCharacter.
		].
	^ dataStream! !

!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:39'!
mimeDecodeToByteArray
	"Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full ByteArray of 0-255 values.  Reutrn a whole stream for the user to read."

	| nibA nibB nibC nibD |
	[mimeStream atEnd] whileFalse: [
		(nibA _ self nextValue) ifNil: [^ dataStream].
		(nibB _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)).
		nibB _ nibB bitAnd: 16rF.
		(nibC _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)).
		nibC _ nibC bitAnd: 16r3.
		(nibD _ self nextValue) ifNil: [^ dataStream].
		dataStream nextPut: ((nibC bitShift: 6) + nibD).
		].
	^ dataStream! !

!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 12:57'!
mimeEncode
	"Convert from data to 6 bit characters."

	| phase1 phase2 raw nib |
	phase1 _ phase2 _ false.
	[dataStream atEnd] whileFalse: [
		data _ raw _ dataStream next asInteger.
		nib _ (data bitAnd: 16rFC) bitShift: -2.
		mimeStream nextPut: (ToCharTable at: nib+1).
		(raw _ dataStream next) ifNil: [raw _ 0. phase1 _ true].
		data _ ((data bitAnd: 3) bitShift: 8) + raw asInteger.
		nib _ (data bitAnd: 16r3F0) bitShift: -4.
		mimeStream nextPut: (ToCharTable at: nib+1).
		(raw _ dataStream next) ifNil: [raw _ 0. phase2 _ true].
		data _ ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger).
		nib _ (data bitAnd: 16rFC0) bitShift: -6.
		mimeStream nextPut: (ToCharTable at: nib+1).
		nib _ (data bitAnd: 16r3F).
		mimeStream nextPut: (ToCharTable at: nib+1)].
	phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=.
			^ mimeStream].
	phase2 ifTrue: [mimeStream skip: -1; nextPut: $=.
			^ mimeStream].

! !

!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:21'!
nextValue
	"The next six bits of data char from the mimeStream, or nil.  Skip all other chars"
	| raw num |
	[raw _ mimeStream next.
	raw ifNil: [^ nil].	"end of stream"
	raw == $= ifTrue: [^ nil].
	num _ FromCharTable at: raw asciiValue + 1.
	num ifNotNil: [^ num].
	"else ignore space, return, tab, ..."
	true] whileTrue.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Base64MimeConverter class
	instanceVariableNames: ''!

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 14:29'!
example
	"Base64MimeConverter example"

| ss bb | 
ss _ ReadWriteStream on: (String new: 10).
ss nextPutAll: 'Hi There!!'.
bb _ Base64MimeConverter mimeEncode: ss.
	"bb contents  'SGkgVGhlcmUh'"
^ (Base64MimeConverter mimeDecodeToChars: bb) contents

! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:53'!
initialize

	FromCharTable _ Array new: 256.	"nils"
	ToCharTable _ Array new: 64.
	($A asciiValue to: $Z asciiValue) doWithIndex: [:val :ind | 
		FromCharTable at: val+1 put: ind-1.
		ToCharTable at: ind put: val asCharacter].
	($a asciiValue to: $z asciiValue) doWithIndex: [:val :ind | 
		FromCharTable at: val+1 put: ind+25.
		ToCharTable at: ind+26 put: val asCharacter].
	($0 asciiValue to: $9 asciiValue) doWithIndex: [:val :ind | 
		FromCharTable at: val+1 put: ind+25+26.
		ToCharTable at: ind+26+26 put: val asCharacter].
	FromCharTable at: $+ asciiValue + 1 put: 62.
	ToCharTable at: 63 put: $+.
	FromCharTable at: $/ asciiValue + 1 put: 63.
	ToCharTable at: 64 put: $/.
	! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:41'!
mimeDecodeToBytes: aStream 
	"Return a RWBinaryOrTextStream of the original ByteArray.  aStream has only 65 innocuous character values.  aStream is not binary.  (See class comment). 4 bytes in aStream goes to 3 bytes in output."

	| me |
	aStream position: 0.
	me _ self new mimeStream: aStream.
	me dataStream: (RWBinaryOrTextStream on: (ByteArray new: aStream size * 3 // 4)).
	me mimeDecodeToByteArray.
	me dataStream position: 0.
	^ me dataStream! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:01'!
mimeDecodeToChars: aStream 
	"Return a ReadWriteStream of the original String.  aStream has only 65 innocuous character values.  It is not binary.  (See class comment). 4 bytes in aStream goes to 3 bytes in output."

	| me |
	aStream position: 0.
	me _ self new mimeStream: aStream.
	me dataStream: (ReadWriteStream on: (String new: aStream size * 3 // 4)).
	me mimeDecode.
	me dataStream position: 0.
	^ me dataStream! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 12:28'!
mimeEncode: aStream
	"Return a ReadWriteStream of characters.  The data of aStream is encoded as 65 innocuous characters.  (See class comment). 3 bytes in aStream goes to 4 bytes in output."

	| me |
	aStream position: 0.
	me _ self new dataStream: aStream.
	me mimeStream: (ReadWriteStream on: (String new: aStream size + 20 * 4 // 3)).
	me mimeEncode.
	me mimeStream position: 0.
	^ me mimeStream! !
Object subclass: #Behavior
	instanceVariableNames: 'superclass methodDict format subclasses '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!Behavior commentStamp: 'di 5/22/1998 16:32' prior: 0!
Behavior comment:
'My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).'!


!Behavior methodsFor: 'initialize-release'!
obsolete
	"Invalidate and recycle local messages. Remove the receiver from its 
	superclass' subclass list."

	methodDict _ MethodDictionary new.
	superclass == nil ifFalse: [superclass removeSubclass: self]! !


!Behavior methodsFor: 'accessing'!
compilerClass
	"Answer a compiler class appropriate for source methods of this class."

	^Compiler! !

!Behavior methodsFor: 'accessing' stamp: 'sw 3/10/97'!
confirmRemovalOf: aSelector
	"Determine if it is okay to remove the given selector.  Answer 1 if it should be removed, 2 if it should be removed followed by a senders browse, and 3 if it should not be removed. 
	9/18/96 sw: made the wording more delicate
	: bug fix -- auto select string needs to be first keyword only"

	| count aMenu answer caption allCalls |
	(count _ (allCalls _ Smalltalk allCallsOn: aSelector) size) > 0
		ifTrue:
			[aMenu _ PopUpMenu labels: 'Remove it
Remove, then browse senders
Don''t remove, but show me those senders
Forget it -- do nothing -- sorry I asked'.

			caption _ 'This message has ', count printString, ' sender'.
			count > 1 ifTrue:
				[caption _ caption copyWith: $s].
			answer _ aMenu startUpWithCaption: caption.
			answer == 3 ifTrue:
				[Smalltalk browseMessageList: allCalls
					name: 'Senders of ', aSelector
					autoSelect: aSelector keywords first].
			answer == 0 ifTrue: [answer _ 3].  "If user didn't answer, treat it as cancel"
			^ answer min: 3]
		ifFalse:
			[^ 1]
	! !

!Behavior methodsFor: 'accessing'!
decompilerClass
	"Answer a decompiler class appropriate for compiled methods of this class."

	^Decompiler! !

!Behavior methodsFor: 'accessing'!
evaluatorClass
	"Answer an evaluator class appropriate for evaluating expressions in the 
	context of this class."

	^Compiler! !

!Behavior methodsFor: 'accessing'!
format
	"Answer an Integer that encodes the kinds and numbers of variables of 
	instances of the receiver."

	^format! !

!Behavior methodsFor: 'accessing'!
parserClass
	"Answer a parser class to use for parsing method headers."

	^self compilerClass parserClass! !

!Behavior methodsFor: 'accessing'!
sourceCodeTemplate
	"Answer an expression to be edited and evaluated in order to define 
	methods in this class."

	^'message selector and argument names
	"comment stating purpose of message"

	| temporary variable names |
	statements'! !

!Behavior methodsFor: 'accessing'!
subclassDefinerClass
	"Answer an evaluator class appropriate for evaluating definitions of new 
	subclasses of this class."

	^Compiler! !


!Behavior methodsFor: 'testing'!
instSize
	"Answer the number of named instance variables
	(as opposed to indexed variables) of the receiver."

	self flag: #instSizeChange.  "Smalltalk browseAllCallsOn: #instSizeChange"
"
	NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
	When we revise the image format, it should become...
	^ ((format bitShift: -1) bitAnd: 16rFF) - 1
	Note also that every other method in this category will require
	2 bits more of right shift after the change.
"
	^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! !

!Behavior methodsFor: 'testing'!
instSpec
	^ (format bitShift: -7) bitAnd: 16rF! !

!Behavior methodsFor: 'testing'!
isBits
	"Answer whether the receiver contains just bits (not pointers)."

	^ self instSpec >= 6! !

!Behavior methodsFor: 'testing'!
isBytes
	"Answer whether the receiver has 8-bit instance variables."

	^ self instSpec >= 8! !

!Behavior methodsFor: 'testing'!
isFixed
	"Answer whether the receiver does not have a variable (indexable) part."

	^self isVariable not! !

!Behavior methodsFor: 'testing'!
isPointers
	"Answer whether the receiver contains just pointers (not bits)."

	^self isBits not! !

!Behavior methodsFor: 'testing'!
isVariable
	"Answer whether the receiver has indexable variables."

	^ self instSpec >= 2! !

!Behavior methodsFor: 'testing'!
isWords
	"Answer whether the receiver has 16-bit instance variables."

	^self isBytes not! !


!Behavior methodsFor: 'copying'!
copy
	"Answer a copy of the receiver without a list of subclasses."

	| myCopy savedSubclasses |
	savedSubclasses _ subclasses.
	subclasses _ nil. 		
	myCopy _ self shallowCopy.
	subclasses _ savedSubclasses.
	^myCopy methodDictionary: methodDict copy! !


!Behavior methodsFor: 'printing' stamp: 'sw 2/16/98 01:30'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver"
	^ self name! !

!Behavior methodsFor: 'printing'!
literalScannedAs: scannedLiteral notifying: requestor
	"Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote).
	If scannedLiteral is not an association, answer it.
	Else, if it is of the form:
		nil->#NameOfMetaclass
	answer nil->theMetaclass, if any has that name, else report an error.
	Else, if it is of the form:
		#NameOfGlobalVariable->anythiEng
	answer the global, class, or pool association with that nameE, if any, else
	add it to Undeclared a answer the new Association."

	| key value |
	(scannedLiteral isMemberOf: Association)
		ifFalse: [^ scannedLiteral].
	key _ scannedLiteral key.
	value _ scannedLiteral value.
	key isNil 
		ifTrue: "###<metaclass soleInstance name>"
			[self scopeHas: value ifTrue:
				[:assoc |
				 (assoc value isKindOf: Behavior)
					ifTrue: [^ nil->assoc value class]].
			 requestor notify: 'No such metaclass'.
			 ^false].
	(key isMemberOf: Symbol)
		ifTrue: "##<global var name>"
			[(self scopeHas: key ifTrue: [:assoc | ^assoc])
				ifFalse:
					[Undeclared at: key put: nil.
					 ^ Undeclared associationAt: key]].
	requestor notify: '## must be followed by a non-local variable name'.
	^false

"	Form literalScannedAs: 14 notifying: nil 14
	Form literalScannedAs: #OneBitForm notiEfying: nil  OneBitForm
	Form literalScannedAs: ##OneBitForm notifying: nil  OneBitForm->a Form
	Form literalScannedAs: ##Form notifying: nil   Form->Form
	Form literalScannedAs: ###Form notifying: nil   nilE->Form class
"! !

!Behavior methodsFor: 'printing'!
printHierarchy
	"Answer a description containing the names and instance variable names 
	of all of the subclasses and superclasses of the receiver."

	| aStream index |
	index _ 0.
	aStream _ WriteStream on: (String new: 16).
	self allSuperclasses reverseDo: 
		[:aClass | 
		aStream crtab: index.
		index _ index + 1.
		aStream nextPutAll: aClass name.
		aStream space.
		aStream print: aClass instVarNames].
	aStream cr.
	self printSubclassesOn: aStream level: index.
	^aStream contents! !

!Behavior methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:." 

	aStream nextPutAll: 'a descendent of '.
	superclass printOn: aStream! !

!Behavior methodsFor: 'printing'!
storeLiteral: aCodeLiteral on: aStream
	"Store aCodeLiteral on aStream, changing an Association to ##GlobalName
	 or ###MetaclassSoleInstanceName format if appropriate"
	| key value |
	(aCodeLiteral isMemberOf: Association)
		ifFalse:
			[aCodeLiteral storeOn: aStream.
			 ^self].
	key _ aCodeLiteral key.
	(key isNil and: [(value _ aCodeLiteral value) isMemberOf: Metaclass])
		ifTrue:
			[aStream nextPutAll: '###'; nextPutAll: value soleInstance name.
			 ^self].
	((key isMemberOf: Symbol) and: [self scopeHas: key ifTrue: [:ignore]])
		ifTrue:
			[aStream nextPutAll: '##'; nextPutAll: key.
			 ^self].
	aCodeLiteral storeOn: aStream! !


!Behavior methodsFor: 'creating class hierarchy'!
addSubclass: aSubclass 
	"Make the argument, aSubclass, be one of the subclasses of the receiver. 
	Create an error notification if the argument's superclass is not the 
	receiver."
	
	aSubclass superclass ~~ self 
		ifTrue: [self error: aSubclass name , ' is not my subclass']
		ifFalse: [subclasses == nil
					ifTrue:	[subclasses _ Set with: aSubclass]
					ifFalse:	[subclasses add: aSubclass]]! !

!Behavior methodsFor: 'creating class hierarchy' stamp: 'tk 3/19/98 10:16'!
removeSubclass: aSubclass 
	"If the argument, aSubclass, is one of the receiver's subclasses, remove it."

	subclasses == nil ifFalse:
		[subclasses remove: aSubclass ifAbsent: [].
		subclasses isEmpty ifTrue: [subclasses _ nil]].
	Object flushCache.
! !

!Behavior methodsFor: 'creating class hierarchy'!
superclass: aClass 
	"Change the receiver's superclass to be aClass."

	(aClass == nil or: [aClass isKindOf: Behavior])
		ifTrue: [superclass _ aClass]
		ifFalse: [self error: 'superclass must be a class-describing object']! !


!Behavior methodsFor: 'creating method dictionary' stamp: 'di 12/26/97 11:04'!
addSelector: selector withMethod: compiledMethod 
	"Add the message selector with the corresponding compiled method to the 
	receiver's method dictionary."

	methodDict at: selector put: compiledMethod.
	selector flushCache! !

!Behavior methodsFor: 'creating method dictionary'!
compile: code 
	"Compile the argument, code, as source code in the context of the 
	receiver. Create an error notification if the code can not be compiled. 
	The argument is either a string or an object that converts to a string or a 
	PositionableStream on an object that converts to a string."

	^self compile: code notifying: nil! !

!Behavior methodsFor: 'creating method dictionary' stamp: 'tk 12/6/97 21:33'!
compile: code notifying: requestor 
	"Compile the argument, code, as source code in the context of the 
	receiver and insEtall the result in the receiver's method dictionary. The 
	second argument, requestor, is to be notified if an error occurs. The 
	argument code is either a string or an object that converts to a string or 
	a PositionableStream. This method also saves the source code."
	| method selector methodNode |
	method _ self
		compile: code "a Text"
		notifying: requestor
		trailer: #(0 0 0 0)
		ifFail: [^nil]
		elseSetSelectorAndNode: 
			[:sel :parseNode | selector _ sel.  methodNode _ parseNode].
	method putSource: code "a Text" fromParseNode: methodNode inFile: 2
			withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr].
	^selector! !

!Behavior methodsFor: 'creating method dictionary'!
compileAll
	^ self compileAllFrom: self! !

!Behavior methodsFor: 'creating method dictionary'!
compileAllFrom: oldClass
	"Compile all the methods in the receiver's method dictionary.
	This validates sourceCode and variable references and forces
	all methods to use the current bytecode set"

	self selectorsDo: [:sel | self recompile: sel from: oldClass]! !

!Behavior methodsFor: 'creating method dictionary'!
compress
	"Compact the method dictionary of the receiver."

	methodDict rehash! !

!Behavior methodsFor: 'creating method dictionary'!
decompile: selector 
	"Find the compiled code associated with the argument, selector, as a 
	message selector in the receiver's method dictionary and decompile it. 
	Answer the resulting source code as a string. Create an error notification 
	if the selector is not in the receiver's method dictionary."

	^self decompilerClass new decompile: selector in: self! !

!Behavior methodsFor: 'creating method dictionary'!
defaultSelectorForMethod: aMethod 
	"Given a method, invent and answer an appropriate message selector (a 
	Symbol), that is, one that will parse with the correct number of 
	arguments."

	| aStream |
	aStream _ WriteStream on: (String new: 16).
	aStream nextPutAll: 'DoIt'.
	1 to: aMethod numArgs do: [:i | aStream nextPutAll: 'with:'].
	^aStream contents asSymbol! !

!Behavior methodsFor: 'creating method dictionary'!
methodDictionary: aDictionary 
	"Store the argument, aDictionary, as the method dictionary of the 
	receiver."

	methodDict _ aDictionary! !

!Behavior methodsFor: 'creating method dictionary'!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."
	| method trailer methodNode |
	method _ self compiledMethodAt: selector.
	trailer _ (method size - 3 to: method size) collect: [:i | method at: i].
	methodNode _ self compilerClass new
				compile: (oldClass sourceCodeAt: selector)
				in: self
				notifying: nil
				ifFail: [^ self].   "Assume OK after proceed from SyntaxError"
	selector == methodNode selector ifFalse: [self error: 'selector changed!!'].
	self addSelector: selector withMethod: (methodNode generate: trailer).
! !

!Behavior methodsFor: 'creating method dictionary'!
recompileChanges
	"Compile all the methods that are in the changes file.
	This validates sourceCode and variable references and forces
	methods to use the current bytecode set"

	self selectorsDo:
		[:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue:
			[self recompile: sel from: self]]! !

!Behavior methodsFor: 'creating method dictionary' stamp: 'di 12/26/97 11:08'!
removeSelector: selector 
	"Assuming that the argument, selector (a Symbol), is a message selector 
	in the receiver's method dictionary, remove it. If the selector is not in 
	the method dictionary, create an error notification."

	methodDict removeKey: selector.
	selector flushCache! !


!Behavior methodsFor: 'instance creation'!
basicNew
	"Primitive. Answer an instance of the receiver (which is a class) with no 
	indexable variables. Fail if the class is indexable. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 70>
	self isVariable ifTrue: [ ^ self basicNew: 0 ].
	"space must be low"
	Smalltalk signalLowSpace.
	^ self basicNew  "retry if user proceeds"
! !

!Behavior methodsFor: 'instance creation'!
basicNew: anInteger 
	"Primitive. Answer an instance of the receiver (which is a class) with the 
	number of indexable variables specified by the argument, anInteger. Fail 
	if the class is not indexable or if the argument is not a positive Integer. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 71>
	(anInteger isInteger and: [anInteger >= 0]) ifTrue: [
		"arg okay; space must be low"
		Smalltalk signalLowSpace.
		^ self basicNew: anInteger  "retry if user proceeds"
	].
	self primitiveFailed! !

!Behavior methodsFor: 'instance creation'!
new
	"Answer a new instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable."
	"Essential Primitive. See Object documentation whatIsAPrimitive."

	<primitive: 70>
	self isVariable ifTrue: [^ self basicNew: 0].
	"space must be low"
	Smalltalk signalLowSpace.
	^ self basicNew  "retry if user proceeds"
! !

!Behavior methodsFor: 'instance creation'!
new: anInteger 
	"Primitive. Answer an instance of the receiver (which is a class) with the 
	number of indexable variables specified by the argument, anInteger. Fail 
	if the class is not indexable or if the argument is not a positive Integer. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 71>
	(anInteger isInteger and: [anInteger >= 0]) ifTrue: [
		"arg okay; space must be low"
		Smalltalk signalLowSpace.
		^ self basicNew: anInteger  "retry if user proceeds"
	].
	self primitiveFailed! !


!Behavior methodsFor: 'accessing class hierarchy'!
allSubclasses
	"Answer a Set of the receiver's and the receiver's descendent's subclasses."

	| aSet |
	aSet _ Set new.
	aSet addAll: self subclasses.
	self subclasses do: [:eachSubclass | aSet addAll: eachSubclass allSubclasses].
	^aSet! !

!Behavior methodsFor: 'accessing class hierarchy'!
allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level 
	"Walk the tree of subclasses, giving the class and its level"
	| subclassNames subclass |
	classAndLevelBlock value: self value: level.
	self == Class ifTrue:  [^ self].  "Don't visit all the metaclasses"
	"Visit subclasses in alphabetical order"
	subclassNames _ SortedCollection new.
	self subclassesDo: [:subC | subclassNames add: subC name].
	subclassNames do:
		[:name | (Smalltalk at: name)
			allSubclassesWithLevelDo: classAndLevelBlock
			startingLevel: level+1]! !

!Behavior methodsFor: 'accessing class hierarchy'!
allSuperclasses
	"Answer an OrderedCollection of the receiver's and the receiver's 
	ancestor's superclasses. The first element is the receiver's immediate 
	superclass, followed by its superclass; the last element is Object."

	| temp |
	superclass == nil
		ifTrue: [^OrderedCollection new]
		ifFalse: [temp _ superclass allSuperclasses.
				temp addFirst: superclass.
				^temp]! !

!Behavior methodsFor: 'accessing class hierarchy'!
subclasses
	"Answer a Set containing the receiver's subclasses."

	subclasses == nil
		ifTrue: [^Set new]
		ifFalse: [^subclasses copy]! !

!Behavior methodsFor: 'accessing class hierarchy'!
superclass
	"Answer the receiver's superclass, a Class."

	^superclass! !

!Behavior methodsFor: 'accessing class hierarchy'!
withAllSubclasses
	"Answer a Set of the receiver, the receiver's descendent's, and the 
	receiver's descendent's subclasses."

	| aSet |
	aSet _ Set with: self.
	aSet addAll: self subclasses.
	self subclasses do: [:eachSubclass | aSet addAll: eachSubclass allSubclasses].
	^aSet! !

!Behavior methodsFor: 'accessing class hierarchy'!
withAllSuperclasses
	"Answer an OrderedCollection of the receiver and the receiver's 
	superclasses. The first element is the receiver, 
	followed by its superclass; the last element is Object."

	| temp |
	temp _ self allSuperclasses.
	temp addFirst: self.
	^ temp! !


!Behavior methodsFor: 'accessing method dictionary'!
allSelectors
	"Answer a Set of all the message selectors that instances of the receiver 
	can understand."

	| temp |
	superclass == nil
		ifTrue: [^self selectors]
		ifFalse: [temp _ superclass allSelectors.
				temp addAll: self selectors.
				^temp]

	"Point allSelectors"! !

!Behavior methodsFor: 'accessing method dictionary'!
changeRecordsAt: selector
	"Return a list of ChangeRecords for all versions of the method at selector.
	Source code can be retrieved by sending string to any one"
	"(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]"
	^ (ChangeList new
			scanVersionsOf: (self compiledMethodAt: selector)
			class: self meta: self isMeta
			category: (self whichCategoryIncludesSelector: selector)
			selector: selector)
		changeList! !

!Behavior methodsFor: 'accessing method dictionary'!
compiledMethodAt: selector 
	"Answer the compiled method associated with the argument, selector (a 
	Symbol), a message selector in the receiver's method dictionary. If the 
	selector is not in the dictionary, create an error notification."

	^methodDict at: selector! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 1/15/98 19:34'!
compiledMethodAt: selector ifAbsent: aBlock
	"Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock"

	^ methodDict at: selector ifAbsent: [aBlock value]! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'tk 1/7/98 10:31'!
compressedSourceCodeAt: selector
	"(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921
	Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450"
	| rawText parse |
	rawText _ (self sourceCodeAt: selector) asString.
	parse _ self compilerClass new parse: rawText in: self notifying: nil.
	^ rawText compressWithTable:
		((selector keywords ,
		parse tempNames ,
		self instVarNames ,
		#(self super ifTrue: ifFalse:) ,
		((0 to: 7) collect:
			[:i | String streamContents:
				[:s | s cr. i timesRepeat: [s tab]]]) ,
		(self compiledMethodAt: selector) literalStrings)
			asSortedCollection: [:a :b | a size > b size])! !

!Behavior methodsFor: 'accessing method dictionary'!
firstCommentAt:  selector
	"Answer a string representing the first comment in the method associated with selector.  Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment.  Not smart enough to bypass quotes in string constants, but ""clever"" enough to map doubled quotes into a single quote.  5/1/96 sw"
	"Behavior firstCommentAt: #firstCommentAt:"

	| sourceString commentStart  pos nextQuotePos |

	sourceString _ self sourceCodeAt: selector.
	sourceString size == 0 ifTrue: [^ ''].
	commentStart _ sourceString findString: '"' startingAt: 1.
	commentStart == 0 ifTrue: [^ ''].
	pos _ commentStart + 1.
	[(nextQuotePos _ sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)]
		whileTrue:
			[pos _ nextQuotePos + 2].
			
	^ (sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"'! !

!Behavior methodsFor: 'accessing method dictionary'!
selectorAtMethod: method setClass: classResultBlock 
	"Answer both the message selector associated with the compiled method 
	and the class in which that selector is defined."

	| sel |
	sel _ methodDict keyAtValue: method
				ifAbsent: 
					[superclass == nil
						ifTrue: 
							[classResultBlock value: self.
							^self defaultSelectorForMethod: method].
					sel _ superclass selectorAtMethod: method setClass: classResultBlock.
					"Set class to be self, rather than that returned from 
					superclass. "
					sel == (self defaultSelectorForMethod: method) ifTrue: [classResultBlock value: self].
					^sel].
	classResultBlock value: self.
	^sel! !

!Behavior methodsFor: 'accessing method dictionary'!
selectors
	"Answer a Set of all the message selectors specified in the receiver's 
	method dictionary."

	^methodDict keys  

	"Point selectors."! !

!Behavior methodsFor: 'accessing method dictionary'!
selectorsDo: selectorBlock
	"Evaluate selectorBlock for all the message selectors in my method dictionary."

	^methodDict keysDo: selectorBlock! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 1/13/98 17:34'!
sourceCodeAt: selector

	^ (methodDict at: selector) getSourceFor: selector in: self! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 11/3/97 00:09'!
sourceCodeAt: selector ifAbsent: aBlock

	^ (methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! !

!Behavior methodsFor: 'accessing method dictionary'!
sourceMethodAt: selector 
	"Answer the paragraph corresponding to the source code for the 
	argument."

	^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 11/3/97 00:10'!
sourceMethodAt: selector ifAbsent: aBlock
	"Answer the paragraph corresponding to the source code for the 
	argument."

	^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! !


!Behavior methodsFor: 'accessing instances and variables'!
allClassVarNames
	"Answer a Set of the names of the receiver's and the receiver's ancestor's 
	class variables."

	^superclass allClassVarNames! !

!Behavior methodsFor: 'accessing instances and variables' stamp: 'jm 5/20/1998 15:53'!
allInstances 
	"Answer a collection of all current instances of the receiver."

	| all |
	all _ OrderedCollection new.
	self allInstancesDo: [:x | x == all ifFalse: [all add: x]].
	^ all asArray
! !

!Behavior methodsFor: 'accessing instances and variables'!
allInstVarNames
	"Answer an Array of the names of the receiver's instance variables. The 
	Array ordering is the order in which the variables are stored and 
	accessed by the interpreter."

	| vars |
	superclass == nil
		ifTrue: [vars _ self instVarNames copy]	"Guarantee a copy is answered."
		ifFalse: [vars _ superclass allInstVarNames , self instVarNames].
	^vars! !

!Behavior methodsFor: 'accessing instances and variables'!
allSharedPools
	"Answer a Set of the names of the pools (Dictionaries) that the receiver 
	and the receiver's ancestors share."

	^superclass allSharedPools! !

!Behavior methodsFor: 'accessing instances and variables' stamp: 'di 6/20/97 10:51'!
allSubInstances 
	"Answer a list of all current instances of the receiver and all of its subclasses."
	| aCollection |
	aCollection _ OrderedCollection new.
	self allSubInstancesDo:
		[:x | x == aCollection ifFalse: [aCollection add: x]].
	^ aCollection! !

!Behavior methodsFor: 'accessing instances and variables'!
classVarNames
	"Answer a Set of the receiver's class variable names."

	^Set new! !

!Behavior methodsFor: 'accessing instances and variables'!
inspectAllInstances 
	"Inpsect all instances of the receiver.  1/26/96 sw"

	| all allSize prefix |
	all _ self allInstances.
	(allSize _ all size) == 0 ifTrue: [^ self notify: 'There are no 
instances of ', self name].
	prefix _ allSize == 1
		ifTrue: 	['The lone instance']
		ifFalse:	['The ', allSize printString, ' instances'].
	
	all asArray inspectWithLabel: (prefix, ' of ', self name)! !

!Behavior methodsFor: 'accessing instances and variables'!
inspectSubInstances 
	"Inspect all instances of the receiver and all its subclasses.  CAUTION - don't do this for something as generic as Object!!  1/26/96 sw"

	| all allSize prefix |
	all _ self allSubInstances.
	(allSize _ all size) == 0 ifTrue: [^ self notify: 'There are no 
instances of ', self name, '
or any of its subclasses'].
	prefix _ allSize == 1
		ifTrue: 	['The lone instance']
		ifFalse:	['The ', allSize printString, ' instances'].
	
	all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! !

!Behavior methodsFor: 'accessing instances and variables'!
instanceCount
	"Answer the number of instances of the receiver that are currently in 
	use."

	| count |
	count _ 0.
	self allInstancesDo: [:x | count _ count + 1].
	^count! !

!Behavior methodsFor: 'accessing instances and variables'!
instVarNames
	"Answer an Array of the instance variable names. Behaviors must make 
	up fake local instance variable names because Behaviors have instance 
	variables for the purpose of compiling methods, but these are not named 
	instance variables."

	| mySize superSize |
	mySize _ self instSize.
	superSize _ 
		superclass == nil
			ifTrue: [0]
			ifFalse: [superclass instSize].
	mySize = superSize ifTrue: [^#()].	
	^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! !

!Behavior methodsFor: 'accessing instances and variables'!
sharedPools
	"Answer a Set of the names of the pools (Dictionaries) that the receiver 
	shares.
	9/12/96 tk  sharedPools have an order now"

	^ OrderedCollection new! !

!Behavior methodsFor: 'accessing instances and variables'!
someInstance
	"Primitive. Answer the first instance in the enumeration of all instances 
	of the receiver. Fails if there are none. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 77>
	^nil! !

!Behavior methodsFor: 'accessing instances and variables'!
subclassInstVarNames
	"Answer a Set of the names of the receiver's subclasses' instance 
	variables."
	| vars |
	vars _ Set new.
	self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames].
	^vars! !


!Behavior methodsFor: 'testing class hierarchy'!
inheritsFrom: aClass 
	"Answer whether the argument, aClass, is on the receiver's superclass 
	chain."

	| aSuperclass |
	aSuperclass _ superclass.
	[aSuperclass == nil]
		whileFalse: 
			[aSuperclass == aClass ifTrue: [^true].
			aSuperclass _ aSuperclass superclass].
	^false! !

!Behavior methodsFor: 'testing class hierarchy'!
kindOfSubclass 
	"Answer a String that is the keyword that describes the receiver's kind of 
	subclass, either a regular subclass, a variableSubclass, a 
	variableByteSubclass, or a variableWordSubclass."

	self isVariable
		ifTrue: [self isBits
					ifTrue: [self isBytes
								ifTrue: [^' variableByteSubclass: ']
								ifFalse: [^' variableWordSubclass: ']]
					ifFalse: [^' variableSubclass: ']]
		ifFalse: [^' subclass: ']! !


!Behavior methodsFor: 'testing method dictionary'!
allUnsentMessages
	"Answer an array of all the messages defined by the receiver that are not sent anywhere in the system.  5/8/96 sw"

	^ Smalltalk allUnSentMessagesIn: self selectors! !

!Behavior methodsFor: 'testing method dictionary'!
canUnderstand: selector 
	"Answer whether the receiver can respond to the message whose selector 
	is the argument. The selector can be in the method dictionary of the 
	receiver's class or any of its superclasses."

	(self includesSelector: selector) ifTrue: [^true].
	superclass == nil ifTrue: [^false].
	^superclass canUnderstand: selector! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'tk 9/13/97 09:53'!
classThatUnderstands: selector
	"Answer the class that can respond to the message whose selector
	is the argument. The selector can be in the method dictionary of the
	receiver's class or any of its superclasses."

	(self includesSelector: selector) ifTrue: [^ self].
	superclass == nil ifTrue: [^ nil].
	^ superclass classThatUnderstands: selector! !

!Behavior methodsFor: 'testing method dictionary'!
hasMethods
	"Answer whether the receiver has any methods in its method dictionary."

	^methodDict size > 0! !

!Behavior methodsFor: 'testing method dictionary'!
includesSelector: aSymbol 
	"Answer whether the message whose selector is the argument is in the 
	method dictionary of the receiver's class."

	^methodDict includesKey: aSymbol! !

!Behavior methodsFor: 'testing method dictionary'!
scopeHas: name ifTrue: assocBlock 
	"If the argument name is a variable known to the receiver, then evaluate 
	the second argument, assocBlock."

	^superclass scopeHas: name ifTrue: assocBlock! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'di 9/5/97 16:16'!
thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte
	"Answer a set of selectors whose methods access the argument as a literal.  Dives into the compact literal notation, making it slow but thorough"
	| who method |
	who _ Set new.
	methodDict associationsDo:
		[:assn |
		method _ assn value.
		((method hasLiteralSuchThat: [:lit | lit == literal]) or:
				[specialFlag and: [method scanFor: specialByte]])
			ifTrue:
			[((literal isMemberOf: Association) not
				or: [method sendsToSuper not
					or: [method literals allButLast includes: literal]])
				ifTrue: [who add: assn key]]].
	^ who! !

!Behavior methodsFor: 'testing method dictionary'!
whichClassIncludesSelector: aSymbol 
	"Answer the class on the receiver's superclass chain where the argument, 
	aSymbol (a message selector), will be found. Answer nil if none found."

	(methodDict includesKey: aSymbol) ifTrue: [^self].
	superclass == nil ifTrue: [^nil].
	^superclass whichClassIncludesSelector: aSymbol

	"Rectangle whichClassIncludesSelector: #inspect."! !

!Behavior methodsFor: 'testing method dictionary'!
whichSelectorsAccess: instVarName 
	"Answer a Set of selectors whose methods access the argument, 
	instVarName, as a named instance variable."

	| instVarIndex |
	instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new].
	^methodDict keys select: 
		[:sel | 
		((methodDict at: sel)
			readsField: instVarIndex)
			or: [(methodDict at: sel) writesField: instVarIndex]]

	"Point whichSelectorsAccess: 'x'."! !

!Behavior methodsFor: 'testing method dictionary'!
whichSelectorsReferTo: literal 
	"Answer a Set of selectors whose methods access the argument as a literal."

	| special |
	special _ Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:byte ].
	^self whichSelectorsReferTo: literal special: special byte: byte

	"Rectangle whichSelectorsReferTo: #+."! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'di 10/17/97 22:39'!
whichSelectorsReferTo: literal special: specialFlag byte: specialByte
	"Answer a set of selectors whose methods access the argument as a literal."
	| who method |
	who _ Set new.
	methodDict associationsDo:
		[:assn |
		method _ assn value.
		((method hasLiteral: literal) or:
				[specialFlag and: [method scanFor: specialByte]])
			ifTrue:
			[((literal isMemberOf: Association) not
				or: [method sendsToSuper not
					or: [method literals allButLast includes: literal]])
				ifTrue: [who add: assn key]]].
	^who! !

!Behavior methodsFor: 'testing method dictionary'!
whichSelectorsStoreInto: instVarName 
	"Answer a Set of selectors whose methods access the argument, 
	instVarName, as a named instance variable."
	| instVarIndex |
	instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new].
	^ methodDict keys select: 
		[:sel | (methodDict at: sel) writesField: instVarIndex]

	"Point whichSelectorsStoreInto: 'x'."! !


!Behavior methodsFor: 'enumerating'!
allInstancesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the current instances of the 
	receiver."
	| inst next |
	self ==  UndefinedObject ifTrue: [^ aBlock value: nil].
	inst _ self someInstance.
	[inst == nil]
		whileFalse:
		[aBlock value: inst.
		inst _ inst nextInstance]! !

!Behavior methodsFor: 'enumerating'!
allSubclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's subclasses."

	self subclassesDo: 
		[:cl | 
		aBlock value: cl.
		cl allSubclassesDo: aBlock]! !

!Behavior methodsFor: 'enumerating' stamp: 'di 6/20/97 10:50'!
allSubInstancesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the current instances of the 
	receiver and all its subclasses."

	self allInstancesDo: aBlock.
	self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! !

!Behavior methodsFor: 'enumerating'!
allSuperclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's superclasses."

	superclass == nil
		ifFalse: [aBlock value: superclass.
				superclass allSuperclassesDo: aBlock]! !

!Behavior methodsFor: 'enumerating'!
selectSubclasses: aBlock 
	"Evaluate the argument, aBlock, with each of the receiver's (next level) 
	subclasses as its argument. Collect into a Set only those subclasses for 
	which aBlock evaluates to true. In addition, evaluate aBlock for the 
	subclasses of each of these successful subclasses and collect into the set 
	those for which aBlock evaluates true. Answer the resulting set."

	| aSet |
	aSet _ Set new.
	self allSubclasses do: 
		[:aSubclass | 
		(aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]].
	^aSet! !

!Behavior methodsFor: 'enumerating'!
selectSuperclasses: aBlock 
	"Evaluate the argument, aBlock, with the receiver's superclasses as the 
	argument. Collect into an OrderedCollection only those superclasses for 
	which aBlock evaluates to true. In addition, evaluate aBlock for the 
	superclasses of each of these successful superclasses and collect into the 
	OrderedCollection ones for which aBlock evaluates to true. Answer the 
	resulting OrderedCollection."

	| aSet |
	aSet _ Set new.
	self allSuperclasses do: 
		[:aSuperclass | 
		(aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]].
	^aSet! !

!Behavior methodsFor: 'enumerating'!
subclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	subclasses == nil ifFalse:
		[subclasses do: [:cl | aBlock value: cl]]! !

!Behavior methodsFor: 'enumerating'!
withAllSubclassesDo: aBlock 
	"Evaluate the argument, aBlock, for the receiver and each of its 
	subclasses."

	aBlock value: self.
	self allSubclassesDo: aBlock! !


!Behavior methodsFor: 'user interface' stamp: 'sw 8/12/97 20:18'!
allCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol."

	| aSortedCollection special |
	aSortedCollection _ SortedCollection new.
	special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:byte ].
	self withAllSubclassesDo:
		[:class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do:
			[:sel | sel ~~ #DoIt ifTrue: [aSortedCollection add: class name , ' ' , sel]]].
	^aSortedCollection! !

!Behavior methodsFor: 'user interface' stamp: 'sw 2/23/98 00:48'!
browse
	Browser newOnClass: self! !

!Behavior methodsFor: 'user interface'!
browseAllAccessesTo: instVarName 	"Collection browseAllAccessesTo: 'contents'."
	"Create and schedule a Message Set browser for all the receiver's methods 
	or any methods of a subclass that refer to the instance variable name."
	| coll |
	coll _ OrderedCollection new.
	Cursor wait 
		showWhile: 
			[self withAllSubclasses do:
				[:class | 
				(class whichSelectorsAccess: instVarName) do: 
					[:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]].
			self allSuperclasses do:
				[:class | 
				(class whichSelectorsAccess: instVarName) do: 
					[:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]].
	^ Smalltalk browseMessageList: coll name: 'Accesses to ' , instVarName autoSelect: instVarName! !

!Behavior methodsFor: 'user interface'!
browseAllCallsOn: aSymbol 
	"Create and schedule a Message Set browser for all the methods that call 
	on aSymbol."
	| key label |
	(aSymbol isKindOf: LookupKey)
			ifTrue: [label _ 'Users of ' , (key _ aSymbol key)]
			ifFalse: [label _ 'Senders of ' , (key _ aSymbol)].
	^ Smalltalk browseMessageList: (self allCallsOn: aSymbol) asSortedCollection
		name: label autoSelect: key

	"Number browseAllCallsOn: #/."! !

!Behavior methodsFor: 'user interface'!
browseAllStoresInto: instVarName 	"Collection browseAllStoresInto: 'contents'."
	"Create and schedule a Message Set browser for all the receiver's methods 
	or any methods of a subclass that refer to the instance variable name."
	| coll |
	coll _ OrderedCollection new.
	Cursor wait 
		showWhile: 
			[self withAllSubclasses do:
				[:class | 
				(class whichSelectorsStoreInto: instVarName) do: 
					[:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]].
			self allSuperclasses do:
				[:class | 
				(class whichSelectorsStoreInto: instVarName) do: 
					[:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]].
	^ Smalltalk browseMessageList: coll name: 'Stores into ' , instVarName autoSelect: instVarName! !

!Behavior methodsFor: 'user interface'!
crossReference
	"Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included."

	^self selectors asSortedCollection asArray collect: [:x | 		Array 
			with: (String with: Character cr), x 
			with: (self whichSelectorsReferTo: x)]

	"Point crossReference."! !

!Behavior methodsFor: 'user interface' stamp: 'sw 2/4/98 15:21'!
removeUninstantiatedSubclassesSilently
	"Remove the classes of any subclasses that have neither instances nor subclasses.  Answer the number of bytes reclaimed"
	"Player removeUninstantiatedSubclassesSilently"

	| candidatesForRemoval  oldFree |

	oldFree _ Smalltalk garbageCollect.
	candidatesForRemoval _
		self subclasses select: [:c |
			(c instanceCount = 0) and: [c subclasses size = 0]].
	candidatesForRemoval do: [:c | c removeFromSystem].
	^ Smalltalk garbageCollect - oldFree! !

!Behavior methodsFor: 'user interface'!
unreferencedInstanceVariables
	"Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses.  2/26/96 sw"

	| any |

	^ self instVarNames copy reject:
		[:ivn | any _ false.
		self withAllSubclasses do:
			[:class |  (class whichSelectorsAccess: ivn) do: 
					[:sel | sel ~~ #DoIt ifTrue: [any _ true]]].
		any]

"Ob unreferencedInstanceVariables"! !


!Behavior methodsFor: 'private'!
becomeCompact
	| cct index |
	cct _ Smalltalk compactClassesArray.
	(self indexIfCompact > 0 or: [cct includes: self])
		ifTrue: [^ self halt: self name , 'is already compact'].
	index _ cct indexOf: nil
		ifAbsent: [^ self halt: 'compact class table is full'].
	"Install this class in the compact class table"
	cct at: index put: self.
	"Update instspec so future instances will be compact"
	format _ format + (index bitShift: 11).
	"Make up new instances and become old ones into them"
	self updateInstancesFrom: self.
	"Purge any old instances"
	Smalltalk garbageCollect.! !

!Behavior methodsFor: 'private'!
becomeUncompact
	| cct index |
	cct _ Smalltalk compactClassesArray.
	(index _ self indexIfCompact) = 0
		ifTrue: [^ self].
	(cct includes: self)
		ifFalse: [^ self halt  "inconsistent state"].
	"Update instspec so future instances will not be compact"
	format _ format - (index bitShift: 11).
	"Make up new instances and become old ones into them"
	self updateInstancesFrom: self.
	"Make sure there are no compact ones left around"
	Smalltalk garbageCollect.
	"Remove this class from the compact class table"
	cct at: index put: nil.
! !

!Behavior methodsFor: 'private'!
flushCache
	"Tell the interpreter to remove the contents of its method lookup cache, if it has 
	one.  Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 89>
	self primitiveFailed! !

!Behavior methodsFor: 'private'!
format: nInstVars variable: isVar words: isWords pointers: isPointers 
	"Set the format for the receiver (a Class)."
	| cClass instSpec sizeHiBits |
	self flag: #instSizeChange.
"
Smalltalk browseAllCallsOn: #instSizeChange.
Smalltalk browseAllImplementorsOf: #fixedFieldsOf:.
Smalltalk browseAllImplementorsOf: #instantiateClass:indexableSize:.
"
"
	NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
	For now the format word is...
		<2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0>
	But when we revise the image format, it should become...
		<5 bits=cClass><4 bits=instSpec><8 bits=instSize><1 bit=0>
"
	sizeHiBits _ (nInstVars+1) // 64.
	cClass _ 0.  "for now"
	instSpec _ isPointers
		ifTrue: [isVar
				ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]]
				ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]]
		ifFalse: [isWords ifTrue: [6] ifFalse: [8]].
	format _ sizeHiBits.
	format _ (format bitShift: 5) + cClass.
	format _ (format bitShift: 4) + instSpec.
	format _ (format bitShift: 6) + ((nInstVars+1)\\64).  "+1 since prim size field includes header"
	format _ (format bitShift: 1) "This shift plus integer bit lets wordSize work like byteSize"
! !

!Behavior methodsFor: 'private'!
indexIfCompact
	"If these 5 bits are non-zero, then instances of this class
	will be compact.  It is crucial that there be an entry in
	Smalltalk compactClassesArray for any class so optimized.
	See the msgs becomeCompact and becomeUncompact."
	^ (format bitShift: -11) bitAnd: 16r1F
"
Smalltalk compactClassesArray doWithIndex: 
	[:c :i | c == nil ifFalse:
		[c indexIfCompact = i ifFalse: [self halt]]]
"! !

!Behavior methodsFor: 'private'!
printSubclassesOn: aStream level: level 
	"As part of the algorithm for printing a description of the receiver, print the
	subclass on the file stream, aStream, indenting level times."

	| subclassNames subclass |
	aStream crtab: level.
	aStream nextPutAll: self name.
	aStream space; print: self instVarNames.
	self == Class
		ifTrue: 
			[aStream crtab: level + 1; nextPutAll: '[ ... all the Metaclasses ... ]'.
			^self].
	subclassNames _ self subclasses collect: [:subC | subC name].
	"Print subclasses in alphabetical order"
	subclassNames asSortedCollection do:
		[:name |
		subclass _ self subclasses detect: [:subC | subC name = name].
		subclass printSubclassesOn: aStream level: level + 1]! !

!Behavior methodsFor: 'private' stamp: 'di 12/26/97 11:07'!
removeSelectorSimply: selector 
	"Remove the message selector from the receiver's method dictionary.
	Internal access from compiler."

	methodDict removeKey: selector ifAbsent: [^self].
	selector flushCache! !
Object subclass: #BitBlt
	instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Support'!
!BitBlt commentStamp: 'di 5/22/1998 16:32' prior: 0!
BitBlt comment:
'I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm.  The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm.  If both are specified, their pixel values are combined with a logical AND function prior to transfer.  In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule.

The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows:
	8:	if source is 0 and destination is 0
	4:	if source is 0 and destination is 1
	2:	if source is 1 and destination is 0
	1:	if source is 1 and destination is 1.
At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions;  if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero.  Forms may be of different depths, see the comment in class Form.

In addition to the original 16 combination rules, this BitBlt supports
	16	fails (to simulate paint bits)
	17	fails (to simulate erase bits)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord.  Sum of color components
	21	rgbSub: sourceWord with: destinationWord.  Sum of color components
	22	rgbDiff: sourceWord with: destinationWord.  Sum of abs of differences in components
	23	tallyIntoMap: destinationWord
	24	alphaBlend: sourceWord with: destinationWord
	25	pixPaint: sourceWord with: destinationWord.  Wherever the sourceForm is non-zero, it replaces the destination.  Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1.
	26	pixMask: sourceWord with: destinationWord.  Like pixPaint, but fills with 0.
	27	rgbMax: sourceWord with: destinationWord.  Max of each color component.
	28	rgbMin: sourceWord with: destinationWord.  Min of each color component.
	29	rgbMin: sourceWord bitInvert32 with: destinationWord.  Min with (max-source)

The color specified by halftoneForm may be either a Color or a Pattern.   A Color is converted to a pixelValue for the depth of the destinationForm.  If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary.  Within each scan line the 32-bit value is repeated from left to right across the form.  If the value repeats on pixels boudaries, the effect will be a constant color;  if not, it will produce a halftone that repeats on 32-bit boundaries.

Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms.
	To make a small Form repeat and fill a big form, use an InfiniteForm as the source.
	To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source.

Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap.  If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits.  The colorMap, if specified, must be a word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source.  For every source pixel, BitBlt will then index this array, and select the corresponding pixelValue and mask it to the destination pixel size before storing.
	When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation.  This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color.  Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped.  The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1.  Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color).
	Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors.
	Colors can be remapped at the same depth.  Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file.  Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of.  MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)'!


!BitBlt methodsFor: 'accessing'!
clipHeight: anInteger 
	"Set the receiver's clipping area height to be the argument, anInteger."

	clipHeight _ anInteger! !

!BitBlt methodsFor: 'accessing'!
clipRect
	"Answer the receiver's clipping area rectangle."

	^clipX @ clipY extent: clipWidth @ clipHeight! !

!BitBlt methodsFor: 'accessing'!
clipRect: aRectangle 
	"Set the receiver's clipping area rectangle to be the argument, aRectangle."

	clipX _ aRectangle left.
	clipY _ aRectangle top.
	clipWidth _ aRectangle width.
	clipHeight _ aRectangle height! !

!BitBlt methodsFor: 'accessing'!
clipWidth: anInteger 
	"Set the receiver's clipping area width to be the argument, anInteger."

	clipWidth _ anInteger! !

!BitBlt methodsFor: 'accessing'!
clipX: anInteger 
	"Set the receiver's clipping area top left x coordinate to be the argument, 
	anInteger."

	clipX _ anInteger! !

!BitBlt methodsFor: 'accessing'!
clipY: anInteger 
	"Set the receiver's clipping area top left y coordinate to be the argument, 
	anInteger."

	clipY _ anInteger! !

!BitBlt methodsFor: 'accessing'!
colorMap
	^ colorMap! !

!BitBlt methodsFor: 'accessing'!
colorMap: map
	"See last part of BitBlt comment. 6/18/96 tk"
	colorMap _ map! !

!BitBlt methodsFor: 'accessing'!
combinationRule: anInteger 
	"Set the receiver's combination rule to be the argument, anInteger, a 
	number in the range 0-15."

	combinationRule _ anInteger! !

!BitBlt methodsFor: 'accessing'!
destForm
	^ destForm! !

!BitBlt methodsFor: 'accessing'!
destOrigin: aPoint 
	"Set the receiver's destination top left coordinates to be those of the 
	argument, aPoint."

	destX _ aPoint x.
	destY _ aPoint y! !

!BitBlt methodsFor: 'accessing' stamp: 'tk 3/19/97'!
destRect
	"The rectangle we are about to blit to or just blitted to.  "

	^ destX @ destY extent: width @ height! !

!BitBlt methodsFor: 'accessing'!
destRect: aRectangle 
	"Set the receiver's destination form top left coordinates to be the origin of 
	the argument, aRectangle, and set the width and height of the receiver's 
	destination form to be the width and height of aRectangle."

	destX _ aRectangle left.
	destY _ aRectangle top.
	width _ aRectangle width.
	height _ aRectangle height! !

!BitBlt methodsFor: 'accessing'!
destX: anInteger 
	"Set the top left x coordinate of the receiver's destination form to be the 
	argument, anInteger."

	destX _ anInteger! !

!BitBlt methodsFor: 'accessing'!
destX: x destY: y width: w height: h
	"Combined init message saves 3 sends from DisplayScanner"
	destX _ x.
	destY _ y.
	width _ w.
	height _ h.! !

!BitBlt methodsFor: 'accessing'!
destY: anInteger 
	"Set the top left y coordinate of the receiver's destination form to be the 
	argument, anInteger."

	destY _ anInteger! !

!BitBlt methodsFor: 'accessing'!
fillColor
	^ halftoneForm! !

!BitBlt methodsFor: 'accessing'!
fillColor: aColorOrPattern 
	"The destForm will be filled with this color or pattern of colors.  May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form.  6/18/96 tk"

	aColorOrPattern == nil ifTrue: [halftoneForm _ nil. ^ self].
	destForm == nil ifTrue: [self error: 'Must set destForm first'].
	halftoneForm _ aColorOrPattern bitPatternForDepth: destForm depth! !

!BitBlt methodsFor: 'accessing'!
height: anInteger 
	"Set the receiver's destination form height to be the argument, anInteger."

	height _ anInteger! !

!BitBlt methodsFor: 'accessing'!
sourceForm

	^ sourceForm! !

!BitBlt methodsFor: 'accessing'!
sourceForm: aForm 
	"Set the receiver's source form to be the argument, aForm."

	sourceForm _ aForm! !

!BitBlt methodsFor: 'accessing'!
sourceOrigin: aPoint 
	"Set the receiver's source form coordinates to be those of the argument, 
	aPoint."

	sourceX _ aPoint x.
	sourceY _ aPoint y! !

!BitBlt methodsFor: 'accessing'!
sourceRect: aRectangle 
	"Set the receiver's source form top left x and y, width and height to be 
	the top left coordinate and extent of the argument, aRectangle."

	sourceX _ aRectangle left.
	sourceY _ aRectangle top.
	width _ aRectangle width.
	height _ aRectangle height! !

!BitBlt methodsFor: 'accessing'!
sourceX: anInteger 
	"Set the receiver's source form top left x to be the argument, anInteger."

	sourceX _ anInteger! !

!BitBlt methodsFor: 'accessing'!
sourceY: anInteger 
	"Set the receiver's source form top left y to be the argument, anInteger."

	sourceY _ anInteger! !

!BitBlt methodsFor: 'accessing'!
width: anInteger 
	"Set the receiver's destination form width to be the argument, anInteger."

	width _ anInteger! !


!BitBlt methodsFor: 'copying'!
copy: destRectangle from: sourcePt in: srcForm
	| destOrigin |
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ 3.  "store"
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	self copyBits! !

!BitBlt methodsFor: 'copying'!
copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule
	"Specify a Color to fill, not a Form. 6/18/96 tk"  
	| destOrigin |
	sourceForm _ srcForm.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule _ rule.
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	^ self copyBits! !

!BitBlt methodsFor: 'copying'!
copy: destRectangle from: sourcePt in: srcForm halftoneForm: hf rule: rule 
	| destOrigin |
	sourceForm _ srcForm.
	self fillColor: hf.		"sets halftoneForm"
	combinationRule _ rule.
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	self copyBits! !

!BitBlt methodsFor: 'copying' stamp: 'di 3/2/98 14:06'!
copyBits
	"Primitive. Perform the movement of bits from the source form to the 
	destination form. Fail if any variables are not of the right type (Integer, 
	Float, or Form) or if the combination rule is not implemented. 
	In addition to the original 16 combination rules, this BitBlt supports
	16	fail (to simulate paint)
	17	fail (to simulate mask)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord
	21	rgbSub: sourceWord with: destinationWord
	22	rgbDiff: sourceWord with: destinationWord
	23	tallyIntoMap: destinationWord
	24	alphaBlend: sourceWord with: destinationWord
	25	pixPaint: sourceWord with: destinationWord
	26	pixMask: sourceWord with: destinationWord
	27	rgbMax: sourceWord with: destinationWord
	28	rgbMin: sourceWord with: destinationWord
	29	rgbMin: sourceWord bitInvert32 with: destinationWord
"
	<primitive: 96>

	"Check for compressed source, destination or halftone forms"
	((sourceForm isKindOf: Form) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBits].
	((destForm isKindOf: Form) and: [destForm unhibernate])
		ifTrue: [^ self copyBits].
	((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate])
		ifTrue: [^ self copyBits].

	"Check for unimplmented rules"
	combinationRule = Form oldPaint ifTrue: [^ self paintBits].
	combinationRule = Form oldErase1bitShape ifTrue: [^ self eraseBits].

	self halt: 'Bad BitBlt arg (Fraction?); proceed to convert.'.
	"Convert all numeric parameters to integers and try again."
	destX _ destX asInteger.
	destY _ destY asInteger.
	width _ width asInteger.
	height _ height asInteger.
	sourceX _ sourceX asInteger.
	sourceY _ sourceY asInteger.
	clipX _ clipX asInteger.
	clipY _ clipY asInteger.
	clipWidth _ clipWidth asInteger.
	clipHeight _ clipHeight asInteger.
	^ self copyBitsAgain! !

!BitBlt methodsFor: 'copying' stamp: 'di 7/17/97 10:04'!
copyForm: srcForm to: destPt rule: rule
	^ self copyForm: srcForm to: destPt rule: rule
		colorMap: (srcForm colormapIfNeededForDepth: destForm depth)! !

!BitBlt methodsFor: 'copying'!
copyForm: srcForm to: destPt rule: rule color: color
	sourceForm _ srcForm.
	halftoneForm _ color.
	combinationRule _ rule.
	destX _ destPt x + sourceForm offset x.
	destY _ destPt y + sourceForm offset y.
	sourceX _ 0.
	sourceY _ 0.
	width _ sourceForm width.
	height _ sourceForm height.
	self copyBits! !

!BitBlt methodsFor: 'copying' stamp: 'di 7/17/97 10:04'!
copyForm: srcForm to: destPt rule: rule colorMap: map
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ rule.
	destX _ destPt x + sourceForm offset x.
	destY _ destPt y + sourceForm offset y.
	sourceX _ 0.
	sourceY _ 0.
	width _ sourceForm width.
	height _ sourceForm height.
	colorMap _ map.
	self copyBits! !

!BitBlt methodsFor: 'copying'!
copyForm: srcForm to: destPt rule: rule fillColor: color
	sourceForm _ srcForm.
	self fillColor: color.	"sets halftoneForm"
	combinationRule _ rule.
	destX _ destPt x + sourceForm offset x.
	destY _ destPt y + sourceForm offset y.
	sourceX _ 0.
	sourceY _ 0.
	width _ sourceForm width.
	height _ sourceForm height.
	self copyBits! !

!BitBlt methodsFor: 'copying' stamp: 'di 7/1/97 14:09'!
copyFrom: sourceRectangle in: srcForm to: destPt
	| sourceOrigin |
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ 3.  "store"
	destX _ destPt x.
	destY _ destPt y.
	sourceOrigin _ sourceRectangle origin.
	sourceX _ sourceOrigin x.
	sourceY _ sourceOrigin y.
	width _ sourceRectangle width.
	height _ sourceRectangle height.
	colorMap _ srcForm colormapIfNeededForDepth: destForm depth.
	self copyBits! !

!BitBlt methodsFor: 'copying'!
fill: destRect fillColor: grayForm rule: rule
	"Fill with a Color, not a Form. 6/18/96 tk"
	sourceForm _ nil.
	self fillColor: grayForm.		"sets halftoneForm"
	combinationRule _ rule.
	destX _ destRect left.
	destY _ destRect top.
	sourceX _ 0.
	sourceY _ 0.
	width _ destRect width.
	height _ destRect height.
	self copyBits! !

!BitBlt methodsFor: 'copying'!
pixelAt: aPoint
	"Assumes this BitBlt has been set up specially (see the init message,
	BitBlt bitPeekerFromForm:.  Returns the pixel at aPoint."
	sourceX _ aPoint x.
	sourceY _ aPoint y.
	destForm bits at: 1 put: 0.  "Just to be sure"
	self copyBits.
	^ destForm bits at: 1! !

!BitBlt methodsFor: 'copying'!
pixelAt: aPoint put: pixelValue
	"Assumes this BitBlt has been set up specially (see the init message,
	BitBlt bitPokerToForm:.  Overwrites the pixel at aPoint."
	destX _ aPoint x.
	destY _ aPoint y.
	sourceForm bits at: 1 put: pixelValue.
	self copyBits
"
| bb |
bb _ (BitBlt bitPokerToForm: Display).
[Sensor anyButtonPressed] whileFalse:
	[bb pixelAt: Sensor cursorPoint put: 55]
"! !


!BitBlt methodsFor: 'line drawing'!
drawFrom: startPoint to: stopPoint 
	
	 ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! !

!BitBlt methodsFor: 'line drawing' stamp: '6/8/97 15:41 di'!
drawFrom: startPoint to: stopPoint withFirstPoint: drawFirstPoint
	"Draw a line whose end points are startPoint and stopPoint.
	The line is formed by repeatedly calling copyBits at every
	point along the line.  If drawFirstPoint is false, then omit
	the first point so as not to overstrike at line junctions."
	| offset point1 point2 forwards |
	"Always draw down, or at least left-to-right"
	forwards _ (startPoint y = stopPoint y and: [startPoint x < stopPoint x])
				or: [startPoint y < stopPoint y].
	forwards
		ifTrue: [point1 _ startPoint. point2 _ stopPoint]
		ifFalse: [point1 _ stopPoint. point2 _ startPoint].
	sourceForm == nil ifTrue:
		[destX _ point1 x.
		destY _ point1 y]
		ifFalse:
		[width _ sourceForm width.
		height _ sourceForm height.
		offset _ sourceForm offset.
		destX _ (point1 x + offset x) rounded.
		destY _ (point1 y + offset y) rounded].

	"Note that if not forwards, then the first point is the last and vice versa.
	We agree to always paint stopPoint, and to optionally paint startPoint."
	(drawFirstPoint or: [forwards == false  "ie this is stopPoint"])
		ifTrue: [self copyBits].
	self drawLoopX: (point2 x - point1 x) rounded 
				  Y: (point2 y - point1 y) rounded.
	(drawFirstPoint or: [forwards  "ie this is stopPoint"])
		ifTrue: [self copyBits].
! !

!BitBlt methodsFor: 'line drawing'!
drawLoopX: xDelta Y: yDelta 
	"Primitive. Implements the Bresenham plotting algorithm (IBM Systems
	Journal, Vol. 4 No. 1, 1965). It chooses a principal direction, and
	maintains a potential, P. When P's sign changes, it is time to move in
	the minor direction as well. This particular version does not write the
	first and last points, so that these can be called for as needed in client code.
	Optional. See Object documentation whatIsAPrimitive."
	| dx dy px py P |
	<primitive: 104>
	dx _ xDelta sign.
	dy _ yDelta sign.
	px _ yDelta abs.
	py _ xDelta abs.
	"self copyBits."
	py > px
		ifTrue: 
			["more horizontal"
			P _ py // 2.
			1 to: py do: 
				[:i |
				destX _ destX + dx.
				(P _ P - px) < 0 ifTrue: 
						[destY _ destY + dy.
						P _ P + py].
				i < py ifTrue: [self copyBits]]]
		ifFalse: 
			["more vertical"
			P _ px // 2.
			1 to: px do:
				[:i |
				destY _ destY + dy.
				(P _ P - py) < 0 ifTrue: 
						[destX _ destX + dx.
						P _ P + px].
				i < px ifTrue: [self copyBits]]]! !


!BitBlt methodsFor: 'private'!
copyBitsAgain
	"Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object
	documentation whatIsAPrimitive."

	<primitive: 96>
	self primitiveFailed! !

!BitBlt methodsFor: 'private'!
eraseBits
	"Perform the erase operation, which puts 0's in the destination
	wherever the source (which is assumed to be just 1 bit deep)
	has a 1.  This requires the colorMap to be set in order to AND
	all 1's into the destFrom pixels regardless of their size."
	| oldMask oldMap |
	oldMask _ halftoneForm.
	halftoneForm _ nil.
	oldMap _ colorMap.
	self colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
	combinationRule _ Form erase.
	self copyBits. 		"Erase the dest wherever the source is 1"
	halftoneForm _ oldMask.	"already converted to a Bitmap"
	colorMap _ oldMap! !

!BitBlt methodsFor: 'private'!
paintBits
	"Perform the paint operation, which requires two calls to BitBlt."
	| color oldMap saveRule |
	sourceForm depth = 1 ifFalse: 
		[^ self halt: 'paint operation is only defined for 1-bit deep sourceForms'].
	saveRule _ combinationRule.
	color _ halftoneForm.  halftoneForm _ nil.
	oldMap _ colorMap.
	"Map 1's to ALL ones, not just one"
	self colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
	combinationRule _ Form erase.
	self copyBits. 		"Erase the dest wherever the source is 1"
	halftoneForm _ color.
	combinationRule _ Form under.
	self copyBits.	"then OR, with whatever color, into the hole"
	colorMap _ oldMap.
	combinationRule _ saveRule

" | dot |
dot _ Form dotOfSize: 32.
((BitBlt destForm: Display
		sourceForm: dot
		fillColor: Color lightGray
		combinationRule: Form paint
		destOrigin: Sensor cursorPoint
		sourceOrigin: 0@0
		extent: dot extent
		clipRect: Display boundingBox)
		colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits"! !

!BitBlt methodsFor: 'private'!
setDestForm: df
	| bb |
	bb _ df boundingBox.
	destForm _ df.
	clipX _ bb left.
	clipY _ bb top.
	clipWidth _ bb width.
	clipHeight _ bb height! !

!BitBlt methodsFor: 'private'!
setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect

	| aPoint |
	destForm _ df.
	sourceForm _ sf.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule _ cr.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourceOrigin x.
	sourceY _ sourceOrigin y.
	width _ extent x.
	height _ extent y.
	aPoint _ clipRect origin.
	clipX _ aPoint x.
	clipY _ aPoint y.
	aPoint _ clipRect corner.
	clipWidth _ aPoint x - clipX.
	clipHeight _ aPoint y - clipY.
	colorMap _ sourceForm colormapIfNeededForDepth: destForm depth.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitBlt class
	instanceVariableNames: ''!

!BitBlt class methodsFor: 'instance creation' stamp: 'di 3/2/98 12:53'!
bitPeekerFromForm: sourceForm
	"Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)."
	| pixPerWord |
	pixPerWord _ 32 // sourceForm depth.
	sourceForm unhibernate.
	^ self destForm: (Form extent: pixPerWord@1 depth: sourceForm depth)
	 	sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: Form over
		destOrigin: (pixPerWord - 1)@0
		sourceOrigin: 0@0
		extent: 1@1
		clipRect: (0@0 extent: pixPerWord@1)
! !

!BitBlt class methodsFor: 'instance creation' stamp: 'di 3/2/98 12:53'!
bitPokerToForm: destForm
	"Answer an instance to be used for valueAt: aPoint put: pixValue.
	The source for a 1x1 copyBits will be the low order of (bits at: 1)"
	| pixPerWord |
	pixPerWord _ 32//destForm depth.
	destForm unhibernate.
	^ self destForm: destForm
	 	sourceForm: (Form extent: pixPerWord@1 depth: destForm depth)
		halftoneForm: nil combinationRule: Form over
		destOrigin: 0@0 sourceOrigin: (pixPerWord-1)@0
		extent: 1@1 clipRect: (0@0 extent: destForm extent)
! !

!BitBlt class methodsFor: 'instance creation'!
destForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 
	"Answer an instance of me with values set according to the arguments."

	^ self new
		setDestForm: df
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: sourceOrigin
		extent: extent
		clipRect: clipRect! !

!BitBlt class methodsFor: 'instance creation'!
destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 
	"Answer an instance of me with values set according to the arguments."

	^ self new
		setDestForm: df
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: sourceOrigin
		extent: extent
		clipRect: clipRect! !

!BitBlt class methodsFor: 'instance creation'!
toForm: aForm
	^ self new setDestForm: aForm! !


!BitBlt class methodsFor: 'examples' stamp: 'di 12/1/97 12:08'!
alphaBlendDemo
	"To run this demo, use...
		Display restoreAfter: [BitBlt alphaBlendDemo]	
	Displays 10 alphas, then lets you paint.  Option-Click to stop painting."

	"This code exhibits alpha blending in any display depth by performing
	the blend in an off-screen buffer with 32-bit pixels, and then copying
	the result back onto the screen with an appropriate color map. - tk 3/10/97"
	
	"This version uses a sliding buffer for painting that keeps pixels in 32 bits
	as long as they are in the buffer, so as not to lose info by converting down
	to display resolution and back up to 32 bits at each operation. - di 3/15/97"

	| brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect |  

	"compute color maps if needed"
	Display depth <= 8 ifTrue: [
		mapDto32 _ Color cachedColormapFrom: Display depth to: 32.
		map32toD _ Color cachedColormapFrom: 32 to: Display depth].

	"display 10 different alphas, across top of screen"
	buff _ Form extent: 500@50 depth: 32.
	dispToBuff _ BitBlt toForm: buff.
	dispToBuff colorMap: mapDto32.
	dispToBuff copyFrom: (50@10 extent: 500@50) in: Display to: 0@0.
	1 to: 10 do: [:i | dispToBuff fill: (50*(i-1)@0 extent: 50@50)
						fillColor: (Color red alpha: i/10)
						rule: Form blend].
	buffToDisplay _ BitBlt toForm: Display.
	buffToDisplay colorMap: map32toD.
	buffToDisplay copyFrom: buff boundingBox in: buff to: 50@10.

	"Create a brush with radially varying alpha"
	brush _ Form extent: 30@30 depth: 32.
	1 to: 5 do: 
		[:i | brush fillShape: (Form dotOfSize: brush width*(6-i)//5)
				fillColor: (Color red alpha: 0.02 * i - 0.01)
				at: brush extent // 2].

	"Now paint with the brush using alpha blending."
	buffSize _ 100.
	buff _ Form extent: brush extent + buffSize depth: 32.  "Travelling 32-bit buffer"
	dispToBuff _ BitBlt toForm: buff.  "This is from Display to buff"
	dispToBuff colorMap: mapDto32.
	brushToBuff _ BitBlt toForm: buff.  "This is from brush to buff"
	brushToBuff sourceForm: brush; sourceOrigin: 0@0.
	brushToBuff combinationRule: Form blend.
	buffToBuff _ BitBlt toForm: buff.  "This is for slewing the buffer"

	[Sensor yellowButtonPressed] whileFalse:
		[prevP _ nil.
		buffRect _ Sensor cursorPoint - (buffSize // 2) extent: buff extent.
		dispToBuff copyFrom: buffRect in: Display to: 0@0.
		[Sensor redButtonPressed] whileTrue:
			["Here is the painting loop"
			p _ Sensor cursorPoint - (brush extent // 2).
			(prevP == nil or: [prevP ~= p]) ifTrue:
				[prevP == nil ifTrue: [prevP _ p].
				(p dist: prevP) > buffSize ifTrue:
					["Stroke too long to fit in buffer -- clip to buffer,
						and next time through will do more of it"
					theta _ (p-prevP) theta.
					p _ ((theta cos@theta sin) * buffSize asFloat + prevP) truncated].
				brushRect _ p extent: brush extent.
				(buffRect containsRect: brushRect) ifFalse:
					["Brush is out of buffer region.  Scroll the buffer,
						and fill vacated regions from the display"
					delta _ brushRect amountToTranslateWithin: buffRect.
					buffToBuff copyFrom: buff boundingBox in: buff to: delta.
					newBuffRect _ buffRect translateBy: delta negated.
					(newBuffRect areasOutside: buffRect) do:
						[:r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin].
					buffRect _ newBuffRect].

				"Interpolate from prevP to p..."
				brushToBuff drawFrom: prevP - buffRect origin
									to: p - buffRect origin
									withFirstPoint: false.

				"Update (only) the altered pixels of the destination"
				updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent.
				buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff.
				prevP _ p]]]! !

!BitBlt class methodsFor: 'examples' stamp: 'di 12/1/97 12:09'!
antiAliasDemo 
	"To run this demo, use...
		Display restoreAfter: [BitBlt antiAliasDemo]
	Goes immediately into on-screen paint mode.  Option-Click to stop painting."

	"This code exhibits alpha blending in any display depth by performing
	the blend in an off-screen buffer with 32-bit pixels, and then copying
	the result back onto the screen with an appropriate color map. - tk 3/10/97"
	
	"This version uses a sliding buffer for painting that keeps pixels in 32 bits
	as long as they are in the buffer, so as not to lose info by converting down
	to display resolution and back up to 32 bits at each operation. - di 3/15/97"
	
	"This version also uses WarpBlt to paint into twice as large a buffer,
	and then use smoothing when reducing back down to the display.
	In fact this same routine will now work for 3x3 soothing as well.
	Remove the statements 'buff displayAt: 0@0' to hide the buffer. - di 3/19/97"

	| brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect scale p0 |  
	"compute color maps if needed"
	Display depth <= 8 ifTrue: [
		mapDto32 _ Color cachedColormapFrom: Display depth to: 32.
		map32toD _ Color cachedColormapFrom: 32 to: Display depth].

	"Create a brush with radially varying alpha"
	brush _ Form extent: 3@3 depth: 32.
	brush fill: brush boundingBox fillColor: (Color red alpha: 0.05).
	brush fill: (1@1 extent: 1@1) fillColor: (Color red alpha: 0.2).

	scale _ 2.  "Actual drawing happens at this magnification"
	"Scale brush up for painting in magnified buffer"
	brush _ brush magnify: brush boundingBox by: scale.

	"Now paint with the brush using alpha blending."
	buffSize _ 100.
	buff _ Form extent: (brush extent + buffSize) * scale depth: 32.  "Travelling 32-bit buffer"
	dispToBuff _ (WarpBlt toForm: buff)  "From Display to buff - magnify by 2"
		sourceForm: Display;
		colorMap: mapDto32;
		combinationRule: Form over.
	brushToBuff _ (BitBlt toForm: buff)  "From brush to buff"
		sourceForm: brush;
		sourceOrigin: 0@0;
		combinationRule: Form blend.
	buffToDisplay _ (WarpBlt toForm: Display)  "From buff to Display - shrink by 2"
		sourceForm: buff;
		colorMap: map32toD;
		cellSize: scale;  "...and use smoothing"
		combinationRule: Form over.
	buffToBuff _ BitBlt toForm: buff.  "This is for slewing the buffer"

	[Sensor yellowButtonPressed] whileFalse:
		[prevP _ nil.
		buffRect _ Sensor cursorPoint - (buff extent // scale // 2) extent: buff extent // scale.
		p0 _ (buff extent // 2) - (buffRect extent // 2).
		dispToBuff copyQuad: buffRect innerCorners toRect: buff boundingBox.
buff displayAt: 0@0.  "** remove to hide sliding buffer **"
		[Sensor redButtonPressed] whileTrue:
			["Here is the painting loop"
			p _ Sensor cursorPoint - buffRect origin + p0.  "p, prevP are rel to buff origin"
			(prevP == nil or: [prevP ~= p]) ifTrue:
				[prevP == nil ifTrue: [prevP _ p].
				(p dist: prevP) > (buffSize-1) ifTrue:
					["Stroke too long to fit in buffer -- clip to buffer,
						and next time through will do more of it"
					theta _ (p-prevP) theta.
					p _ ((theta cos@theta sin) * (buffSize-2) asFloat + prevP) truncated].
				brushRect _ p extent: brush extent.
				((buff boundingBox insetBy: scale) containsRect: brushRect) ifFalse:
					["Brush is out of buffer region.  Scroll the buffer,
						and fill vacated regions from the display"
					delta _ (brushRect amountToTranslateWithin: (buff boundingBox insetBy: scale)) // scale.
					buffToBuff copyFrom: buff boundingBox in: buff to: delta*scale.
					newBuffRect _ buffRect translateBy: delta negated.
					p _ p translateBy: delta*scale.
					prevP _ prevP translateBy: delta*scale.
					(newBuffRect areasOutside: buffRect) do:
						[:r | dispToBuff copyQuad: r innerCorners toRect: (r origin - newBuffRect origin*scale extent: r extent*scale)].
					buffRect _ newBuffRect].

				"Interpolate from prevP to p..."
				brushToBuff drawFrom: prevP to: p withFirstPoint: false.
buff displayAt: 0@0.  "** remove to hide sliding buffer **"

				"Update (only) the altered pixels of the destination"
				updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent.
				updateRect _ updateRect origin // scale * scale
						corner: updateRect corner + scale // scale * scale.
				buffToDisplay copyQuad: updateRect innerCorners
							toRect: (updateRect origin // scale + buffRect origin
										extent: updateRect extent // scale).
				prevP _ p]]]! !

!BitBlt class methodsFor: 'examples'!
exampleOne
	"This tests BitBlt by displaying the result of all sixteen combination rules that BitBlt is capable of using. (Please see the comment in BitBlt for the meaning of the combination rules)."
	| path |
	path _ Path new.
	0 to: 3 do: [:i | 0 to: 3 do: [:j | path add: j * 100 @ (i * 75)]].
	Display fillWhite.
	path _ path translateBy: 60 @ 40.
	1 to: 16 do: [:index | BitBlt
			exampleAt: (path at: index)
			rule: index - 1
			fillColor: Color black]

	"BitBlt exampleOne"! !

!BitBlt class methodsFor: 'examples'!
exampleTwo
	"This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for a while and then automatically stops."
	| f aBitBlt |
	"create a small black Form source as a brush. "
	f _ Form extent: 20 @ 20.
	f fillBlack.
	"create a BitBlt which will OR gray into the display. "
	aBitBlt _ BitBlt
		destForm: Display
		sourceForm: f
		fillColor: Color gray
		combinationRule: Form under
		destOrigin: Sensor cursorPoint
		sourceOrigin: 0 @ 0
		extent: f extent
		clipRect: Display computeBoundingBox.
	"paint the gray Form on the screen for a while. "
	[Sensor anyButtonPressed] whileFalse: 
		[aBitBlt destOrigin: Sensor cursorPoint.
		aBitBlt copyBits]

	"BitBlt exampleTwo"! !


!BitBlt class methodsFor: 'private'!
exampleAt: originPoint rule: rule fillColor: mask 
	"This builds a source and destination form and copies the source to the
	destination using the specifed rule and mask. It is called from the method
	named exampleOne."

	| s d border aBitBlt | 
	border_Form extent: 32@32.
	border fillBlack.
	border fill: (1@1 extent: 30@30) fillColor: Color white.
	s _ Form extent: 32@32.
	s fillWhite.
	s fillBlack: (7@7 corner: 25@25).
	d _ Form extent: 32@32.
	d fillWhite.
	d fillBlack: (0@0 corner: 32@16).

	s displayOn: Display at: originPoint.
	border displayOn: Display at: originPoint rule: Form under.
	d displayOn: Display at: originPoint + (s width @0).
	border displayOn: Display at: originPoint + (s width @0) rule: Form under.

	d displayOn: Display at: originPoint + (s extent // (2 @ 1)).
	aBitBlt _ BitBlt
		destForm: Display
		sourceForm: s
		fillColor: mask
		combinationRule: rule
		destOrigin: originPoint + (s extent // (2 @ 1))
		sourceOrigin: 0 @ 0
		extent: s extent
		clipRect: Display computeBoundingBox.
	aBitBlt copyBits.
	border 
		displayOn: Display at: originPoint + (s extent // (2 @ 1))
		rule: Form under.
   
	"BitBlt exampleAt: 100@100 rule: Form over fillColor: Display gray"! !
Object subclass: #BitBltSimulation
	instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight sourceBits sourceRaster sourcePixSize destBits destRaster destPixSize pixPerWord bitCount skew mask1 mask2 preload nWords hDir vDir sourceIndex sourceDelta destIndex destDelta sx sy dx dy bbW bbH srcWidth srcHeight halftoneHeight noSource noHalftone halftoneBase colorMap cmBitsPerColor srcBitIndex scanStart scanStop scanString scanRightX scanStopArray scanDisplayFlag scanXTable stopCode bitBltOop affectedL affectedR affectedT affectedB interpreterProxy opTable '
	classVariableNames: 'AllOnes BBClipHeightIndex BBClipWidthIndex BBClipXIndex BBClipYIndex BBColorMapIndex BBDestFormIndex BBDestXIndex BBDestYIndex BBHalftoneFormIndex BBHeightIndex BBLastIndex BBRuleIndex BBSourceFormIndex BBSourceXIndex BBSourceYIndex BBWarpBase BBWidthIndex BBXTableIndex BinaryPoint CrossedX EndOfRun FixedPt1 FormBitsIndex FormDepthIndex FormHeightIndex FormWidthIndex OpTable OpTableSize '
	poolDictionaries: ''
	category: 'Squeak-Interpreter'!
!BitBltSimulation commentStamp: 'di 5/22/1998 16:32' prior: 0!
BitBltSimulation comment:
'This class implements BitBlt, much as specified in the Blue Book spec.

Performance has been enhanced through the use of pointer variables such as sourceIndex and destIndex, and by separating several special cases of the inner loop.

Operation has been extended to color, with support for 1, 2, 4, 8, 16, and 32-bit pixel sizes.  Conversion between different pixel sizes is facilitated by accepting an optional color map.

In addition to the original 16 combination rules, this BitBlt supports
	16	fail (to simulate paint)
	17	fail (to simulate mask)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord
	21	rgbSub: sourceWord with: destinationWord
	22	rgbDiff: sourceWord with: destinationWord
	23	tallyIntoMap: destinationWord
	24	alphaBlend: sourceWord with: destinationWord
	25	pixPaint: sourceWord with: destinationWord
	26	pixMask: sourceWord with: destinationWord
	27	rgbMax: sourceWord with: destinationWord
	28	rgbMin: sourceWord with: destinationWord
	29	rgbMin: sourceWord bitInvert32 with: destinationWord

This implementation has also been fitted with an experimental "warp drive" that allows abritrary scaling and rotation (and even limited affine deformations) with all BitBlt storage modes supported.
'!


!BitBltSimulation methodsFor: 'interpreter interface'!
drawLoopX: xDelta Y: yDelta 
	"This is the primitive implementation of the line-drawing loop.
	See the comments in BitBlt>>drawLoopX:Y:"
	| dx1 dy1 px py P affL affR affT affB |
	xDelta > 0
		ifTrue: [dx1 _ 1]
		ifFalse: [xDelta = 0
				ifTrue: [dx1 _ 0]
				ifFalse: [dx1 _ -1]].
	yDelta > 0
		ifTrue: [dy1 _ 1]
		ifFalse: [yDelta = 0
				ifTrue: [dy1 _ 0]
				ifFalse: [dy1 _ -1]].
	px _ yDelta abs.
	py _ xDelta abs.
	affL _ affT _ 9999.  "init null rectangle"
	affR _ affB _ -9999.
	py > px
		ifTrue: 
			["more horizontal"
			P _ py // 2.
			1 to: py do: 
				[:i |
				destX _ destX + dx1.
				(P _ P - px) < 0 ifTrue: 
					[destY _ destY + dy1.
					P _ P + py].
				i < py ifTrue:
					[self copyBits.
					(affectedL < affectedR and: [affectedT < affectedB]) ifTrue:
						["Affected rectangle grows along the line"
						affL _ affL min: affectedL.
						affR _ affR max: affectedR.
						affT _ affT min: affectedT.
						affB _ affB max: affectedB.
						(affR - affL) * (affB - affT) > 4000 ifTrue:
							["If affected rectangle gets large, update it in chunks"
							affectedL _ affL.  affectedR _ affR.
							affectedT _ affT.  affectedB _ affB.
							interpreterProxy showDisplayBits.
							affL _ affT _ 9999.  "init null rectangle"
							affR _ affB _ -9999]].
					]]]
		ifFalse: 
			["more vertical"
			P _ px // 2.
			1 to: px do:
				[:i |
				destY _ destY + dy1.
				(P _ P - py) < 0 ifTrue: 
					[destX _ destX + dx1.
					P _ P + px].
				i < px ifTrue:
					[self copyBits.
					(affectedL < affectedR and: [affectedT < affectedB]) ifTrue:
						["Affected rectangle grows along the line"
						affL _ affL min: affectedL.
						affR _ affR max: affectedR.
						affT _ affT min: affectedT.
						affB _ affB max: affectedB.
						(affR - affL) * (affB - affT) > 4000 ifTrue:
							["If affected rectangle gets large, update it in chunks"
							affectedL _ affL.  affectedR _ affR.
							affectedT _ affT.  affectedB _ affB.
							interpreterProxy showDisplayBits.
							affL _ affT _ 9999.  "init null rectangle"
							affR _ affB _ -9999]].
					]]].

	"Remaining affected rect"
	affectedL _ affL.  affectedR _ affR.
	affectedT _ affT.  affectedB _ affB.

	"store destX, Y back"	
	interpreterProxy storeInteger: BBDestXIndex ofObject: bitBltOop withValue: destX.
	interpreterProxy storeInteger: BBDestYIndex ofObject: bitBltOop withValue: destY.! !

!BitBltSimulation methodsFor: 'interpreter interface'!
loadBitBltFrom: bbObj
	"Load context from BitBlt instance.  Return false if anything is amiss"
	"NOTE this should all be changed to minX/maxX coordinates for simpler clipping
		-- once it works!!"
	| destBitsSize destWidth destHeight sourceBitsSize sourcePixPerWord cmSize halftoneBits |
	bitBltOop _ bbObj.
	combinationRule _ interpreterProxy fetchInteger: BBRuleIndex ofObject: bitBltOop.
	(interpreterProxy failed
		or: [combinationRule < 0 or: [combinationRule > 29]])
		 ifTrue: [^ false  "operation out of range"].
	(combinationRule >= 16 and: [combinationRule <= 17])
		 ifTrue: [^ false  "fail for old simulated paint, erase modes"].
	sourceForm _ interpreterProxy fetchPointer: BBSourceFormIndex ofObject: bitBltOop.
	noSource _ self ignoreSourceOrHalftone: sourceForm.
	halftoneForm _ interpreterProxy fetchPointer: BBHalftoneFormIndex ofObject: bitBltOop.
	noHalftone _ self ignoreSourceOrHalftone: halftoneForm.

	destForm _ interpreterProxy fetchPointer: BBDestFormIndex ofObject: bitBltOop.
		((interpreterProxy isPointers: destForm) and: [(interpreterProxy lengthOf: destForm) >= 4])
			ifFalse: [^ false].
		destBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
		destBitsSize _ interpreterProxy byteLengthOf: destBits.
		destWidth _ interpreterProxy fetchInteger: FormWidthIndex ofObject: destForm.
		destHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: destForm.
		(destWidth >= 0 and: [destHeight >= 0])
			ifFalse: [^ false].
		destPixSize _ interpreterProxy fetchInteger: FormDepthIndex ofObject: destForm.
		pixPerWord _ 32 // destPixSize.
		destRaster _ destWidth + (pixPerWord-1) // pixPerWord.
		((interpreterProxy isWordsOrBytes: destBits)
			and: [destBitsSize = (destRaster * destHeight * 4)])
			ifFalse: [^ false].	
	destX _ interpreterProxy fetchIntegerOrTruncFloat: BBDestXIndex ofObject: bitBltOop.
	destY _ interpreterProxy fetchIntegerOrTruncFloat: BBDestYIndex ofObject: bitBltOop.
	width _ interpreterProxy fetchIntegerOrTruncFloat: BBWidthIndex ofObject: bitBltOop.
	height _ interpreterProxy fetchIntegerOrTruncFloat: BBHeightIndex ofObject: bitBltOop.
		interpreterProxy failed ifTrue: [^ false  "non-integer value"].

	noSource ifTrue:
		[sourceX _ sourceY _ 0]
		ifFalse: 
		[((interpreterProxy isPointers: sourceForm) and: [(interpreterProxy lengthOf: sourceForm) >= 4])
			ifFalse: [^ false].
		sourceBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
		sourceBitsSize _ interpreterProxy byteLengthOf: sourceBits.
		srcWidth _ interpreterProxy fetchIntegerOrTruncFloat: FormWidthIndex ofObject: sourceForm.
		srcHeight _ interpreterProxy fetchIntegerOrTruncFloat: FormHeightIndex ofObject: sourceForm.
		(srcWidth >= 0 and: [srcHeight >= 0])
			ifFalse: [^ false].
		sourcePixSize _ interpreterProxy fetchInteger: FormDepthIndex ofObject: sourceForm.
		sourcePixPerWord _ 32 // sourcePixSize.
		sourceRaster _ srcWidth + (sourcePixPerWord-1) // sourcePixPerWord.
		((interpreterProxy isWordsOrBytes: sourceBits)
			and: [sourceBitsSize = (sourceRaster * srcHeight * 4)])
			ifFalse: [^ false].
		colorMap _ interpreterProxy fetchPointer: BBColorMapIndex ofObject: bitBltOop.
		"ColorMap, if not nil, must be longWords, and 
		2^N long, where N = sourcePixSize for 1, 2, 4, 8 bits, 
		or N = 9, 12, or 15 (3, 4, 5 bits per color) for 16 or 32 bits."
		colorMap = interpreterProxy nilObject ifFalse:
			[(interpreterProxy isWords: colorMap)
			ifTrue:
			[cmSize _ interpreterProxy lengthOf: colorMap.
			cmBitsPerColor _ 0.
			cmSize = 512 ifTrue: [cmBitsPerColor _ 3].
			cmSize = 4096 ifTrue: [cmBitsPerColor _ 4].
			cmSize = 32768 ifTrue: [cmBitsPerColor _ 5].
			interpreterProxy primIndex ~= 147 ifTrue:
				["WarpBlt has different checks on the color map"
				sourcePixSize <= 8
				ifTrue: [cmSize = (1 << sourcePixSize) ifFalse: [^ false] ]
				ifFalse: [cmBitsPerColor = 0 ifTrue: [^ false] ]]
			]
			ifFalse: [^ false]].
		sourceX _ interpreterProxy fetchIntegerOrTruncFloat: BBSourceXIndex ofObject: bitBltOop.
		sourceY _ interpreterProxy fetchIntegerOrTruncFloat: BBSourceYIndex ofObject: bitBltOop].

	noHalftone ifFalse: 
		[((interpreterProxy isPointers: halftoneForm) and: [(interpreterProxy lengthOf: halftoneForm) >= 4])
		ifTrue:
		["Old-style 32xN monochrome halftone Forms"
		halftoneBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: halftoneForm.
		halftoneHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: halftoneForm.
		(interpreterProxy isWords: halftoneBits)
			ifFalse: [noHalftone _ true]]
		ifFalse:
		["New spec accepts, basically, a word array"
		((interpreterProxy isPointers: halftoneForm) not
			and: [interpreterProxy isWords: halftoneForm])
			ifFalse: [^ false].
		halftoneBits _ halftoneForm.
		halftoneHeight _ interpreterProxy lengthOf: halftoneBits].
	halftoneBase _ halftoneBits + 4].

	clipX _ interpreterProxy fetchIntegerOrTruncFloat: BBClipXIndex ofObject: bitBltOop.
	clipY _ interpreterProxy fetchIntegerOrTruncFloat: BBClipYIndex ofObject: bitBltOop.
	clipWidth _ interpreterProxy fetchIntegerOrTruncFloat: BBClipWidthIndex ofObject: bitBltOop.
	clipHeight _ interpreterProxy fetchIntegerOrTruncFloat: BBClipHeightIndex ofObject: bitBltOop.
		interpreterProxy failed ifTrue: [^ false  "non-integer value"].
	clipX < 0 ifTrue: [clipWidth _ clipWidth + clipX.  clipX _ 0].
	clipY < 0 ifTrue: [clipHeight _ clipHeight + clipY.  clipY _ 0].
	clipX+clipWidth > destWidth ifTrue: [clipWidth _ destWidth - clipX].
	clipY+clipHeight > destHeight ifTrue: [clipHeight _ destHeight - clipY].

	^ true! !

!BitBltSimulation methodsFor: 'interpreter interface'!
loadScannerFrom: bbObj
	start: start stop: stop string: string rightX: rightX
	stopArray: stopArray displayFlag: displayFlag

	self inline: false.
	"Load arguments and Scanner state"
	scanStart _ start.
	scanStop _ stop.
	scanString _ string.
	scanRightX _ rightX.
	scanStopArray _ stopArray.
	scanDisplayFlag _ displayFlag.
	interpreterProxy success: (
		(interpreterProxy isPointers: scanStopArray)
			and: [(interpreterProxy lengthOf: scanStopArray) >= 1]).
	scanXTable _ interpreterProxy fetchPointer: BBXTableIndex ofObject: bbObj.
	interpreterProxy success: (
		(interpreterProxy isPointers: scanXTable)
			and: [(interpreterProxy lengthOf: scanXTable) >= 1]).

	"width and sourceX may not be set..."
	interpreterProxy storeInteger: BBWidthIndex ofObject: bbObj withValue: 0.
	interpreterProxy storeInteger: BBSourceXIndex ofObject: bbObj withValue: 0.

	"Now load BitBlt state if displaying"
	scanDisplayFlag
		ifTrue: [interpreterProxy success: (self loadBitBltFrom: bbObj)]
		ifFalse: [bitBltOop _ bbObj.
				destX _ interpreterProxy fetchIntegerOrTruncFloat: BBDestXIndex ofObject: bbObj].
	^interpreterProxy failed not! !

!BitBltSimulation methodsFor: 'interpreter interface'!
scanCharacters

	| left top lastIndex charVal ascii sourceX2 nextDestX |
	scanDisplayFlag ifTrue:
		[self clipRange.  "Need to get true x, y for affectedRectangle"
		left _ dx.
		top _ dy].
	lastIndex _ scanStart.
	[lastIndex <= scanStop]
		whileTrue: [
			charVal _ interpreterProxy stObject: scanString at: lastIndex.
			ascii _ interpreterProxy integerValueOf: charVal.
			interpreterProxy failed ifTrue: [^ nil].
			stopCode _ interpreterProxy stObject: scanStopArray at: ascii + 1.
			interpreterProxy failed ifTrue: [^ nil].
			stopCode = interpreterProxy nilObject
				ifFalse: [^ self returnAt: ascii + 1
							 lastIndex: lastIndex
								  left: left
								  top: top].
			sourceX _ interpreterProxy stObject: scanXTable at: ascii + 1.
			sourceX2 _ interpreterProxy stObject: scanXTable at: ascii + 2.
			interpreterProxy failed ifTrue: [^ nil].
			(interpreterProxy isIntegerObject: sourceX) & (interpreterProxy isIntegerObject: sourceX2)
				ifTrue: [sourceX _ interpreterProxy integerValueOf: sourceX.
						sourceX2 _ interpreterProxy integerValueOf: sourceX2]
				ifFalse: [interpreterProxy primitiveFail. ^ nil].
			nextDestX _ destX + (width _ sourceX2 - sourceX).
			nextDestX > scanRightX
				ifTrue: [^ self returnAt: CrossedX
							 lastIndex: lastIndex
								  left: left
								  top: top].
			scanDisplayFlag ifTrue: [self copyBits].
			destX _ nextDestX.
			interpreterProxy storeInteger: BBDestXIndex ofObject: bitBltOop withValue: destX.
			lastIndex _ lastIndex + 1].
	self returnAt: EndOfRun
		 lastIndex: scanStop
			  left: left
			  top: top! !

!BitBltSimulation methodsFor: 'interpreter interface'!
setInterpreter: anInterpreter
	"Interface for InterpreterSimulator. Allows BitBltSimulation object to send messages to the interpreter. The translator will replace sends to 'interpreterProxy' with sends to self, as if BitBltSimulation were part of the interpreter."

	interpreterProxy _ anInterpreter.! !


!BitBltSimulation methodsFor: 'accessing'!
affectedBottom

	^affectedB! !

!BitBltSimulation methodsFor: 'accessing'!
affectedLeft

	^affectedL! !

!BitBltSimulation methodsFor: 'accessing'!
affectedRight

	^affectedR! !

!BitBltSimulation methodsFor: 'accessing'!
affectedTop

	^affectedT! !

!BitBltSimulation methodsFor: 'accessing'!
stopReason

	^stopCode! !

!BitBltSimulation methodsFor: 'accessing'!
targetForm
	"Return the destination form of a copyBits or scanCharacters operation."

	^destForm! !


!BitBltSimulation methodsFor: 'setup'!
checkSourceOverlap
	| t |
	"check for possible overlap of source and destination"
	(sourceForm = destForm and: [dy >= sy]) ifTrue:
		[dy > sy ifTrue:
			["have to start at bottom"
			vDir _ -1.
			sy _ sy + bbH - 1.
			dy _ dy + bbH - 1]
		ifFalse:
			[dx > sx ifTrue:
				["y's are equal, but x's are backward"
				hDir _ -1.
				sx _ sx + bbW - 1.
				"start at right"
				dx _ dx + bbW - 1.
				"and fix up masks"
				nWords > 1 ifTrue: 
					[t _ mask1.
					mask1 _ mask2.
					mask2 _ t]]].
		"Dest inits may be affected by this change"
		destIndex _ (destBits + 4) + (dy * destRaster + (dx // pixPerWord) *4).
		destDelta _ 4 * ((destRaster * vDir) - (nWords * hDir))]! !

!BitBltSimulation methodsFor: 'setup'!
clipRange
	"clip and adjust source origin and extent appropriately"
	"first in x"
	destX >= clipX
		ifTrue: [sx _ sourceX.
				dx _ destX.
				bbW _ width]
		ifFalse: [sx _ sourceX + (clipX - destX).
				bbW _ width - (clipX - destX).
				dx _ clipX].
	(dx + bbW) > (clipX + clipWidth)
		ifTrue: [bbW _ bbW - ((dx + bbW) - (clipX + clipWidth))].
	"then in y"
	destY >= clipY
		ifTrue: [sy _ sourceY.
				dy _ destY.
				bbH _ height]
		ifFalse: [sy _ sourceY + clipY - destY.
				bbH _ height - (clipY - destY).
				dy _ clipY].
	(dy + bbH) > (clipY + clipHeight)
		ifTrue: [bbH _ bbH - ((dy + bbH) - (clipY + clipHeight))].
	noSource ifTrue: [^ nil].
	sx < 0
		ifTrue: [dx _ dx - sx.
				bbW _ bbW + sx.
				sx _ 0].
	sx + bbW > srcWidth
		ifTrue: [bbW _ bbW - (sx + bbW - srcWidth)].
	sy < 0
		ifTrue: [dy _ dy - sy.
				bbH _ bbH + sy.
				sy _ 0].
	sy + bbH > srcHeight
		ifTrue: [bbH _ bbH - (sy + bbH - srcHeight)]! !

!BitBltSimulation methodsFor: 'setup'!
copyBits
	self clipRange.
	(bbW <= 0 or: [bbH <= 0]) ifTrue:
		["zero width or height; noop"
		affectedL _ affectedR _ affectedT _ affectedB _ 0.
		^ nil].
 
	self destMaskAndPointerInit.
	bitCount _ 0.
	noSource
		ifTrue: [self copyLoopNoSource]
		ifFalse: [self checkSourceOverlap.
				(sourcePixSize ~= destPixSize
					or: [colorMap ~= interpreterProxy nilObject])
					ifTrue: [self copyLoopPixMap]
					ifFalse: [self sourceSkewAndPointerInit.
							self copyLoop]].
 
	combinationRule = 22 ifTrue:
		["zero width and height; return the count"
		affectedL _ affectedR _ affectedT _ affectedB _ 0.
		interpreterProxy pop: 1.
		^ interpreterProxy pushInteger: bitCount].
 
	hDir > 0
		ifTrue: [affectedL _ dx.
				affectedR _ dx + bbW]
		ifFalse: [affectedL _ dx - bbW + 1.
				affectedR _ dx + 1].
	vDir > 0
		ifTrue: [affectedT _ dy.
				affectedB _ dy + bbH]
		ifFalse: [affectedT _ dy - bbH + 1.
				affectedB _ dy + 1]! !

!BitBltSimulation methodsFor: 'setup'!
destMaskAndPointerInit
	"Compute masks for left and right destination words"
	| startBits pixPerM1 endBits |
	pixPerM1 _ pixPerWord - 1.  "A mask, assuming power of two"
	"how many pixels in first word"
	startBits _ pixPerWord - (dx bitAnd: pixPerM1).
	mask1 _ AllOnes >> (32 - (startBits*destPixSize)).
	"how many pixels in last word"
	endBits _ ((dx + bbW - 1) bitAnd: pixPerM1) + 1.
	mask2 _ AllOnes << (32 - (endBits*destPixSize)).
	"determine number of words stored per line; merge masks if only 1"
	bbW < startBits
		ifTrue: [mask1 _ mask1 bitAnd: mask2.
				mask2 _ 0.
				nWords _ 1]
		ifFalse: [nWords _ (bbW - startBits) + pixPerM1 // pixPerWord + 1].
	hDir _ vDir _ 1. "defaults for no overlap with source"

	"calculate byte addr and delta, based on first word of data"
	"Note raster and nwords are longs, not bytes"
	destIndex _ (destBits + 4) + (dy * destRaster + (dx // pixPerWord) *4).
	destDelta _ 4 * ((destRaster * vDir) - (nWords * hDir)).  "byte addr delta"! !

!BitBltSimulation methodsFor: 'setup'!
ignoreSourceOrHalftone: formPointer

	formPointer = interpreterProxy nilObject ifTrue: [ ^true ].
	combinationRule = 0 ifTrue: [ ^true ].
	combinationRule = 5 ifTrue: [ ^true ].
	combinationRule = 10 ifTrue: [ ^true ].
	combinationRule = 15 ifTrue: [ ^true ].
	^false! !

!BitBltSimulation methodsFor: 'setup'!
returnAt: stopIndex lastIndex: lastIndex left: left top: top

	stopCode _ interpreterProxy stObject: scanStopArray at: stopIndex.
	interpreterProxy failed ifTrue: [^ nil].
	interpreterProxy storeInteger: BBLastIndex ofObject: bitBltOop withValue: lastIndex.
	scanDisplayFlag ifTrue: [
		"Now we know extent of affected rectangle"
		affectedL _ left.
		affectedR _ bbW + dx.
		affectedT _ top.
		affectedB _ bbH + dy.
	].! !

!BitBltSimulation methodsFor: 'setup'!
sourceSkewAndPointerInit
	"This is only used when source and dest are same depth,
	ie, when the barrel-shift copy loop is used."
	| dWid sxLowBits dxLowBits pixPerM1 |
	pixPerM1 _ pixPerWord - 1.  "A mask, assuming power of two"
	sxLowBits _ sx bitAnd: pixPerM1.
	dxLowBits _ dx bitAnd: pixPerM1.
	"check if need to preload buffer
	(i.e., two words of source needed for first word of destination)"
	hDir > 0 ifTrue:
		["n Bits stored in 1st word of dest"
		dWid _ bbW min: pixPerWord - dxLowBits.
		preload _ (sxLowBits + dWid) > pixPerM1]
	ifFalse:
		[dWid _ bbW min: dxLowBits + 1.
		preload _ (sxLowBits - dWid + 1) < 0].

	"calculate right-shift skew from source to dest"
	skew _ (sxLowBits - dxLowBits) * destPixSize.  " -32..32 "
	preload ifTrue: 
		[skew < 0
			ifTrue: [skew _ skew+32]
			ifFalse: [skew _ skew-32]].

	"Calc byte addr and delta from longWord info"
	sourceIndex _ (sourceBits + 4) + (sy * sourceRaster + (sx // (32//sourcePixSize)) *4).
	"calculate increments from end of 1 line to start of next"
	sourceDelta _ 4 * ((sourceRaster * vDir) - (nWords * hDir)).
	preload ifTrue:
		["Compensate for extra source word fetched"
		sourceDelta _ sourceDelta - (4*hDir)].! !

!BitBltSimulation methodsFor: 'setup'!
warpBits
	| ns |
	ns _ noSource.  noSource _ true.
		self clipRange.  "noSource suppresses sourceRect clipping"
		noSource _ ns.
	(noSource or: [bbW <= 0 or: [bbH <= 0]]) ifTrue:
		["zero width or height; noop"
		affectedL _ affectedR _ affectedT _ affectedB _ 0.
		^ nil].
 
	self destMaskAndPointerInit.
	self warpLoop.
 
	hDir > 0
		ifTrue: [affectedL _ dx.
				affectedR _ dx + bbW]
		ifFalse: [affectedL _ dx - bbW + 1.
				affectedR _ dx + 1].
	vDir > 0
		ifTrue: [affectedT _ dy.
				affectedB _ dy + bbH]
		ifFalse: [affectedT _ dy - bbH + 1.
				affectedB _ dy + 1]! !


!BitBltSimulation methodsFor: 'inner loop' stamp: 'di 12/30/97 14:42'!
copyLoop
	| prevWord thisWord skewWord halftoneWord mergeWord hInc y unskew skewMask notSkewMask mergeFnwith |
	"This version of the inner loop assumes noSource = false."
	self inline: false.
	self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
	mergeFnwith.  "null ref for compiler"

	hInc _ hDir*4.  "Byte delta"
	"degenerate skew fixed for Sparc. 10/20/96 ikp"
	skew == -32
		ifTrue: [skew _ unskew _ skewMask _ 0]
		ifFalse: [skew < 0
			ifTrue:
				[unskew _ skew+32.
				skewMask _ AllOnes << (0-skew)]
			ifFalse:
				[skew == 0
					ifTrue:
						[unskew _ 0.
						skewMask _ AllOnes]
					ifFalse:
						[unskew _ skew-32.
						skewMask _ AllOnes >> skew]]].
	notSkewMask _ skewMask bitInvert32.
	noHalftone
		ifTrue: [halftoneWord _ AllOnes.  halftoneHeight _ 0]
		ifFalse: [halftoneWord _ interpreterProxy longAt: halftoneBase].
	y _ dy.
	1 to: bbH do: "here is the vertical loop"
		[ :i |
		halftoneHeight > 1 ifTrue:  "Otherwise, its always the same"
			[halftoneWord _ interpreterProxy longAt:
						(halftoneBase + (y \\ halftoneHeight * 4)).
			y _ y + vDir].
		preload ifTrue:
			["load the 64-bit shifter"
			prevWord _ interpreterProxy longAt: sourceIndex.
			sourceIndex _ sourceIndex + hInc]
			ifFalse:
			[prevWord _ 0].

	"Note: the horizontal loop has been expanded into three parts for speed:"

			"This first section requires masking of the destination store..."
			thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			sourceIndex _ sourceIndex + hInc.
			mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
							with: (interpreterProxy longAt: destIndex).
			interpreterProxy longAt: destIndex
				put: ((mask1 bitAnd: mergeWord)
					bitOr: (mask1 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
			destIndex _ destIndex + hInc.

		"This central horizontal loop requires no store masking"
combinationRule = 3
ifTrue: [2 to: nWords-1 do: "Special inner loop for STORE"
			[ :word |
			thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			sourceIndex _ sourceIndex + hInc.
			interpreterProxy longAt: destIndex put: (skewWord bitAnd: halftoneWord).
			destIndex _ destIndex + hInc]
] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge:"
			[ :word |
			thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			sourceIndex _ sourceIndex + hInc.
			mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
							with: (interpreterProxy longAt: destIndex).
			interpreterProxy longAt: destIndex put: mergeWord.
			destIndex _ destIndex + hInc]
].

		"This last section, if used, requires masking of the destination store..."
		nWords > 1 ifTrue:
			[thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			sourceIndex _ sourceIndex + hInc.
			mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
							with: (interpreterProxy longAt: destIndex).
			interpreterProxy longAt: destIndex
				put: ((mask2 bitAnd: mergeWord)
					bitOr: (mask2 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
			destIndex _ destIndex + hInc].

	sourceIndex _ sourceIndex + sourceDelta.
	destIndex _ destIndex + destDelta]! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'di 12/30/97 14:43'!
copyLoopNoSource
	| halftoneWord mergeWord mergeFnwith |
	"Faster copyLoop when source not used.  hDir and vDir are both
	positive, and perload and skew are unused"

	self inline: false.
	self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
	mergeFnwith.  "null ref for compiler"

	1 to: bbH do: "here is the vertical loop"
		[ :i |
		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].

	"Note: the horizontal loop has been expanded into three parts for speed:"

			"This first section requires masking of the destination store..."
			mergeWord _ self mergeFn: halftoneWord
							with: (interpreterProxy longAt: destIndex).
			interpreterProxy longAt: destIndex
				put: ((mask1 bitAnd: mergeWord)
					bitOr: (mask1 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
			destIndex _ destIndex + 4.

		"This central horizontal loop requires no store masking"
combinationRule = 3
ifTrue: [2 to: nWords-1 do: "Special inner loop for STORE"
			[ :word |
			interpreterProxy longAt: destIndex put: halftoneWord.
			destIndex _ destIndex + 4].
] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge"
			[ :word |
			mergeWord _ self mergeFn: halftoneWord
							with: (interpreterProxy longAt: destIndex).
			interpreterProxy longAt: destIndex put: mergeWord.
			destIndex _ destIndex + 4].

].

		"This last section, if used, requires masking of the destination store..."
		nWords > 1 ifTrue:
			[mergeWord _ self mergeFn: halftoneWord
							with: (interpreterProxy longAt: destIndex).
			interpreterProxy longAt: destIndex
				put: ((mask2 bitAnd: mergeWord)
					bitOr: (mask2 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
			destIndex _ destIndex + 4].

	destIndex _ destIndex + destDelta]! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'di 12/30/97 14:45'!
copyLoopPixMap
	"This version of the inner loop maps source pixels
	to a destination form with different depth.  Because it is already
	unweildy, the loop is not unrolled as in the other versions.
	Preload, skew and skewMask are all overlooked, since pickSourcePixels
	delivers its destination word already properly aligned.
	Note that pickSourcePixels could be copied in-line at the top of
	the horizontal loop, and some of its inits moved out of the loop."

	| skewWord halftoneWord mergeWord destMask srcPixPerWord scrStartBits nSourceIncs startBits endBits sourcePixMask destPixMask nullMap mergeFnwith |

	self inline: false.
	self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
	mergeFnwith.  "null ref for compiler"

	"Additional inits peculiar to unequal source and dest pix size..."
	srcPixPerWord _ 32//sourcePixSize.
	"Check for degenerate shift values 4/28/97 ar"
	sourcePixSize = 32 
		ifTrue: [ sourcePixMask _ -1]
		ifFalse: [ sourcePixMask _ (1 << sourcePixSize) - 1].
	destPixSize = 32
		ifTrue: [ destPixMask _ -1]
		ifFalse: [ destPixMask _ (1 << destPixSize) - 1].
	nullMap _ colorMap = interpreterProxy nilObject.
	sourceIndex _ (sourceBits + 4) +
					(sy * sourceRaster + (sx // srcPixPerWord) *4).
	scrStartBits _ srcPixPerWord - (sx bitAnd: srcPixPerWord-1).
	bbW < scrStartBits
		ifTrue: [nSourceIncs _ 0]
		ifFalse: [nSourceIncs _ (bbW - scrStartBits)//srcPixPerWord + 1].
	sourceDelta _ (sourceRaster - nSourceIncs) * 4.

	"Note following two items were already calculated in destmask setup!!"
	startBits _ pixPerWord - (dx bitAnd: pixPerWord-1).
	endBits _ ((dx + bbW - 1) bitAnd: pixPerWord-1) + 1.

	1 to: bbH do: "here is the vertical loop"
		[ :i |
		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].
		srcBitIndex _ (sx bitAnd: srcPixPerWord - 1)*sourcePixSize.
		destMask _ mask1.
		"pick up first word"
		bbW < startBits
			ifTrue: [skewWord _ self pickSourcePixels: bbW nullMap: nullMap
									srcMask: sourcePixMask destMask: destPixMask.
					skewWord _ skewWord   "See note below"
							bitShift: (startBits - bbW)*destPixSize]
			ifFalse: [skewWord _ self pickSourcePixels: startBits nullMap: nullMap
									srcMask: sourcePixMask destMask: destPixMask]. 

		"Here is the horizontal loop..."
		1 to: nWords do: "here is the inner horizontal loop"
			[ :word |
			mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
							with: ((interpreterProxy longAt: destIndex) bitAnd: destMask).
			interpreterProxy longAt: destIndex
				put: ((destMask bitAnd: mergeWord)
					bitOr:
					(destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
			destIndex _ destIndex + 4.
			word >= (nWords - 1) ifTrue:
				[word = nWords ifFalse:
					["set mask for last word in this row"
					destMask _ mask2.
					skewWord _ self pickSourcePixels: endBits nullMap: nullMap
									srcMask: sourcePixMask destMask: destPixMask.
					skewWord _ skewWord   "See note below"
							bitShift: (pixPerWord-endBits)*destPixSize]]
				ifFalse: 
				["use fullword mask for inner loop"
				destMask _ AllOnes.
				skewWord _ self pickSourcePixels: pixPerWord nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask]].

	sourceIndex _ sourceIndex + sourceDelta.
	destIndex _ destIndex + destDelta]

"NOTE: in both noted shifts above, we are shifting the right-justified
 output of pickSourcePixels so that it is aligned with the destination word.
  Since it gets masked anyway, we could have just picked more pixels
 (startBits in the first case and destPixSize in the second), and it would
 have been simpler, but it is slower to run the pickSourcePixels loop. 
 CopyLoopAlphaHack takes advantage of this to avoid having to shift
 full-words in its alphaSource buffer" ! !

!BitBltSimulation methodsFor: 'inner loop'!
warpLoop
	| skewWord halftoneWord mergeWord destMask startBits
	  deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy
	  xDelta yDelta pBx pBy smoothingCount sourceMapOop nSteps t |

	"This version of the inner loop traverses an arbirary quadrilateral
	source, thus producing a general affine transformation."
 
	(interpreterProxy fetchWordLengthOf: bitBltOop) >= (BBWarpBase+12)
		ifFalse: [^ interpreterProxy primitiveFail].
	nSteps _ height-1.  nSteps <= 0 ifTrue: [nSteps _ 1].

	pAx _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase ofObject: bitBltOop.
	t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+3 ofObject: bitBltOop.
	deltaP12x _ self deltaFrom: pAx to: t nSteps: nSteps.
	deltaP12x < 0 ifTrue: [pAx _ t - (nSteps*deltaP12x)].

	pAy _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+1 ofObject: bitBltOop.
	t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+4 ofObject: bitBltOop.
	deltaP12y _ self deltaFrom: pAy to: t nSteps: nSteps.
	deltaP12y < 0 ifTrue: [pAy _ t - (nSteps*deltaP12y)].

	pBx _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+9 ofObject: bitBltOop.
	t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+6 ofObject: bitBltOop.
	deltaP43x _ self deltaFrom: pBx to: t nSteps: nSteps.
	deltaP43x < 0 ifTrue: [pBx _ t - (nSteps*deltaP43x)].

	pBy _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+10 ofObject: bitBltOop.
	t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+7 ofObject: bitBltOop.
	deltaP43y _ self deltaFrom: pBy to: t nSteps: nSteps.
	deltaP43y < 0 ifTrue: [pBy _ t - (nSteps*deltaP43y)].

	interpreterProxy failed ifTrue: [^ false].  "ie if non-integers above"
	interpreterProxy argCount = 2
		ifTrue: [smoothingCount _ interpreterProxy stackIntegerValue: 1.
				sourceMapOop _ interpreterProxy stackValue: 0.
				sourceMapOop = interpreterProxy nilObject
				ifTrue: [sourcePixSize < 16 ifTrue:
					["color map is required to smooth non-RGB dest"
					^ interpreterProxy primitiveFail]]
				ifFalse: [(interpreterProxy fetchWordLengthOf: sourceMapOop)
							< (1 << sourcePixSize) ifTrue:
					["sourceMap must be long enough for sourcePixSize"
					^ interpreterProxy primitiveFail]]]
		ifFalse: [smoothingCount _ 1.
				sourceMapOop _ interpreterProxy nilObject].
	startBits _ pixPerWord - (dx bitAnd: pixPerWord-1).
	nSteps _ width-1.  nSteps <= 0 ifTrue: [nSteps _ 1].
 
	destY to: clipY-1 do:
		[ :i |	"Advance increments if there was clipping in y"
		pAx _ pAx + deltaP12x.
		pAy _ pAy + deltaP12y.
		pBx _ pBx + deltaP43x.
		pBy _ pBy + deltaP43y].

	1 to: bbH do:
		[ :i |		"here is the vertical loop..."
		xDelta _ self deltaFrom: pAx to: pBx nSteps: nSteps.
 		xDelta >= 0 ifTrue: [sx _ pAx] ifFalse: [sx _ pBx - (nSteps*xDelta)].
		yDelta _ self deltaFrom: pAy to: pBy nSteps: nSteps.
 		yDelta >= 0 ifTrue: [sy _ pAy] ifFalse: [sy _ pBy - (nSteps*yDelta)].

		destX to: clipX-1 do:
			[:word |	"Advance increments if there was clipping in x"
			sx _ sx + xDelta.
			sy _ sy + yDelta].

		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].
		destMask _ mask1.
		"pick up first word"
		bbW < startBits
			ifTrue: [skewWord _ self warpSourcePixels: bbW
									xDeltah: xDelta yDeltah: yDelta
									xDeltav: deltaP12x yDeltav: deltaP12y
									smoothing: smoothingCount sourceMap: sourceMapOop.
					skewWord _ skewWord
							bitShift: (startBits - bbW)*destPixSize]
			ifFalse: [skewWord _ self warpSourcePixels: startBits
									xDeltah: xDelta yDeltah: yDelta
									xDeltav: deltaP12x yDeltav: deltaP12y
									smoothing: smoothingCount sourceMap: sourceMapOop].
 
		1 to: nWords do:
			[ :word |		"here is the inner horizontal loop..."
			mergeWord _ self merge: (skewWord bitAnd: halftoneWord)
				with: ((interpreterProxy longAt: destIndex) bitAnd: destMask).
			interpreterProxy longAt: destIndex
				put: ((destMask bitAnd: mergeWord)
					bitOr:
					(destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
			destIndex _ destIndex + 4.
			word >= (nWords - 1) ifTrue:
				[word = nWords ifFalse:
					["set mask for last word in this row"
					destMask _ mask2.
					skewWord _ self warpSourcePixels: pixPerWord
									xDeltah: xDelta yDeltah: yDelta
									xDeltav: deltaP12x yDeltav: deltaP12y
									smoothing: smoothingCount sourceMap: sourceMapOop]]
				ifFalse:
				["use fullword mask for inner loop"
				destMask _ AllOnes.
				skewWord _ self warpSourcePixels: pixPerWord
									xDeltah: xDelta yDeltah: yDelta
									xDeltav: deltaP12x yDeltav: deltaP12y
									smoothing: smoothingCount sourceMap: sourceMapOop].
			].
		pAx _ pAx + deltaP12x.
		pAy _ pAy + deltaP12y.
		pBx _ pBx + deltaP43x.
		pBy _ pBy + deltaP43y.
		destIndex _ destIndex + destDelta]! !


!BitBltSimulation methodsFor: 'combination rules'!
addWord: sourceWord with: destinationWord
	^sourceWord + destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
alphaBlend: sourceWord with: destinationWord
	"Blend sourceWord with destinationWord, assuming both are 32-bit pixels.
	The source is assumed to have 255*alpha in the high 8 bits of each pixel,
	while the high 8 bits of the destinationWord will be ignored.
	The blend produced is alpha*source + (1-alpha)*dest, with
	the computation being performed independently on each color
	component.  The high byte of the result will be 0."
	| alpha unAlpha colorMask result blend shift |
	self inline: false.
	alpha _ sourceWord >> 24.  "High 8 bits of source pixel"
	unAlpha _ 255 - alpha.
	colorMask _ 16rFF.
	result _ 0.
	1 to: 3 do:
		[:i | shift _ (i-1)*8.
		blend _ (((sourceWord>>shift bitAnd: colorMask) * alpha)
					+ ((destinationWord>>shift bitAnd: colorMask) * unAlpha))
			 	+ 254 // 255 bitAnd: colorMask.
		result _ result bitOr: blend<<shift].
	^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
bitAnd: sourceWord with: destinationWord
	^sourceWord bitAnd: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitAndInvert: sourceWord with: destinationWord
	^sourceWord bitAnd: destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertAnd: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitAnd: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertAndInvert: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitAnd: destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertDestination: sourceWord with: destinationWord
	^destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertOr: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitOr: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertOrInvert: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitOr: destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertSource: sourceWord with: destinationWord
	^sourceWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertXor: sourceWord with: destinationWord
	^sourceWord bitInvert32 bitXor: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitOr: sourceWord with: destinationWord
	^sourceWord bitOr: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitOrInvert: sourceWord with: destinationWord
	^sourceWord bitOr: destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitXor: sourceWord with: destinationWord
	^sourceWord bitXor: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
clearWord: source with: destination
	^ 0! !

!BitBltSimulation methodsFor: 'combination rules'!
destinationWord: sourceWord with: destinationWord
	^destinationWord! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 12/30/97 14:46'!
merge: sourceWord with: destinationWord
	| mergeFnwith |
	"Sender warpLoop is too big to include this in-line"
	self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
	mergeFnwith.  "null ref for compiler"

	^ self mergeFn: sourceWord with: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedAdd: word1 to: word2 nBits: nBits nPartitions: nParts
	"Add word1 to word2 as nParts partitions of nBits each.
	This is useful for packed pixels, or packed colors"
	| mask sum result |
	mask _ (1 << nBits) - 1.  "partition mask starts at the right"
	result _ 0.
	1 to: nParts do:
		[:i |
		sum _ (word1 bitAnd: mask) + (word2 bitAnd: mask).
		sum <= mask  "result must not carry out of partition"
			ifTrue: [result _ result bitOr: sum]
			ifFalse: [result _ result bitOr: mask].
		mask _ mask << nBits  "slide left to next partition"].
	^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedAND: word1 to: word2 nBits: nBits nPartitions: nParts
	"AND word1 to word2 as nParts partitions of nBits each.
	Any field of word1 not all-ones is treated as all-zeroes.
	Used for erasing, eg, brush shapes prior to ORing in a color"
	| mask result |
	mask _ (1 << nBits) - 1.  "partition mask starts at the right"
	result _ 0.
	1 to: nParts do:
		[:i |
		(word1 bitAnd: mask) = mask
			ifTrue: [result _ result bitOr: (word2 bitAnd: mask)].
		mask _ mask << nBits  "slide left to next partition"].
	^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedMax: word1 with: word2 nBits: nBits nPartitions: nParts
	"Max word1 to word2 as nParts partitions of nBits each"
	| mask result |
	mask _ (1 << nBits) - 1.  "partition mask starts at the right"
	result _ 0.
	1 to: nParts do:
		[:i |
		result _ result bitOr: ((word2 bitAnd: mask) max: (word1 bitAnd: mask)).
		mask _ mask << nBits  "slide left to next partition"].
	^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedMin: word1 with: word2 nBits: nBits nPartitions: nParts
	"Min word1 to word2 as nParts partitions of nBits each"
	| mask result |
	mask _ (1 << nBits) - 1.  "partition mask starts at the right"
	result _ 0.
	1 to: nParts do:
		[:i |
		result _ result bitOr: ((word2 bitAnd: mask) min: (word1 bitAnd: mask)).
		mask _ mask << nBits  "slide left to next partition"].
	^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedSub: word1 from: word2 nBits: nBits nPartitions: nParts
	"Subtract word1 from word2 as nParts partitions of nBits each.
	This is useful for packed pixels, or packed colors"
	| mask result p1 p2 |
	mask _ (1 << nBits) - 1.  "partition mask starts at the right"
	result _ 0.
	1 to: nParts do:
		[:i |
		p1 _ word1 bitAnd: mask.
		p2 _ word2 bitAnd: mask.
		p1 < p2  "result is really abs value of thedifference"
			ifTrue: [result _ result bitOr: p2 - p1]
			ifFalse: [result _ result bitOr: p1 - p2].
		mask _ mask << nBits  "slide left to next partition"].
	^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
pixMask: sourceWord with: destinationWord
	self inline: false.
	^ self partitionedAND: sourceWord bitInvert32 to: destinationWord
					nBits: destPixSize nPartitions: pixPerWord! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 12/27/97 10:39'!
pixPaint: sourceWord with: destinationWord
	self inline: false.
	sourceWord = 0 ifTrue: [^ destinationWord].
	^ sourceWord bitOr:
		(self partitionedAND: sourceWord bitInvert32 to: destinationWord
						nBits: destPixSize nPartitions: pixPerWord)! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbAdd: sourceWord with: destinationWord
	self inline: false.
	destPixSize < 16 ifTrue:
		["Add each pixel separately"
		^ self partitionedAdd: sourceWord to: destinationWord
						nBits: destPixSize nPartitions: pixPerWord].
	destPixSize = 16 ifTrue:
		["Add RGB components of each pixel separately"
		^ (self partitionedAdd: sourceWord to: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedAdd: sourceWord>>16 to: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Add RGB components of the pixel separately"
		^ self partitionedAdd: sourceWord to: destinationWord
						nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbDiff: sourceWord with: destinationWord
	"Subract the pixels in the source and destination, color by color,
	and return the sum of the absolute value of all the differences.
	For non-rgb, XOR the two and return the number of differing pixels.
	Note that the region is not clipped to bit boundaries, but only to the
	nearest (enclosing) word.  This is because copyLoop does not do
	pre-merge masking.  For accurate results, you must subtract the
	values obtained from the left and right fringes."
	| diff pixMask |
	self inline: false.
	destPixSize < 16 ifTrue:
		["Just xor and count differing bits if not RGB"
		diff _ sourceWord bitXor: destinationWord.
		pixMask _ (1 bitShift: destPixSize) - 1.
		[diff = 0] whileFalse:
			[(diff bitAnd: pixMask) ~= 0 ifTrue: [bitCount _ bitCount + 1].
			diff _ diff >> destPixSize].
		^ destinationWord "for no effect"].
 	destPixSize = 16
		ifTrue:
		[diff _ (self partitionedSub: sourceWord from: destinationWord
						nBits: 5 nPartitions: 3).
		bitCount _ bitCount + (diff bitAnd: 16r1F)
							+ (diff>>5 bitAnd: 16r1F)
							+ (diff>>10 bitAnd: 16r1F).
		diff _ (self partitionedSub: sourceWord>>16 from: destinationWord>>16
						nBits: 5 nPartitions: 3).
		bitCount _ bitCount + (diff bitAnd: 16r1F)
							+ (diff>>5 bitAnd: 16r1F)
							+ (diff>>10 bitAnd: 16r1F)]
		ifFalse:
		[diff _ (self partitionedSub: sourceWord from: destinationWord
						nBits: 8 nPartitions: 3).
		bitCount _ bitCount + (diff bitAnd: 16rFF)
							+ (diff>>8 bitAnd: 16rFF)
							+ (diff>>16 bitAnd: 16rFF)].
	^ destinationWord  "For no effect on dest"! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbMax: sourceWord with: destinationWord
	self inline: false.
	destPixSize < 16 ifTrue:
		["Max each pixel separately"
		^ self partitionedMax: sourceWord with: destinationWord
						nBits: destPixSize nPartitions: pixPerWord].
	destPixSize = 16 ifTrue:
		["Max RGB components of each pixel separately"
		^ (self partitionedMax: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMax: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Max RGB components of the pixel separately"
		^ self partitionedMax: sourceWord with: destinationWord
						nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbMin: sourceWord with: destinationWord
	self inline: false.
	destPixSize < 16 ifTrue:
		["Min each pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: destPixSize nPartitions: pixPerWord].
	destPixSize = 16 ifTrue:
		["Min RGB components of each pixel separately"
		^ (self partitionedMin: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMin: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Min RGB components of the pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 1/21/98 21:57'!
rgbMinInvert: wordToInvert with: destinationWord
	| sourceWord |
	self inline: false.
	sourceWord _ wordToInvert bitInvert32.
	destPixSize < 16 ifTrue:
		["Min each pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: destPixSize nPartitions: pixPerWord].
	destPixSize = 16 ifTrue:
		["Min RGB components of each pixel separately"
		^ (self partitionedMin: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMin: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Min RGB components of the pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbSub: sourceWord with: destinationWord
	self inline: false.
	destPixSize < 16 ifTrue:
		["Sub each pixel separately"
		^ self partitionedSub: sourceWord from: destinationWord
						nBits: destPixSize nPartitions: pixPerWord].
	destPixSize = 16 ifTrue:
		["Sub RGB components of each pixel separately"
		^ (self partitionedSub: sourceWord from: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedSub: sourceWord>>16 from: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Sub RGB components of the pixel separately"
		^ self partitionedSub: sourceWord from: destinationWord
						nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules'!
sourceWord: sourceWord with: destinationWord
	^sourceWord! !

!BitBltSimulation methodsFor: 'combination rules'!
subWord: sourceWord with: destinationWord
	^sourceWord - destinationWord! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 1/21/98 06:31'!
tallyIntoMap: sourceWord with: destinationWord
	"Tally pixels into the color map.  Note that the source should be 
	specified = destination, in order for the proper color map checks 
	to be performed at setup.
	Note that the region is not clipped to bit boundaries, but only to the
	nearest (enclosing) word.  This is because copyLoop does not do
	pre-merge masking.  For accurate results, you must subtract the
	values obtained from the left and right fringes."
	| mapIndex pixMask shiftWord |
	colorMap = interpreterProxy nilObject
		ifTrue: [^ destinationWord "no op"].
	destPixSize < 16 ifTrue:
		["loop through all packed pixels."
		pixMask _ (1<<destPixSize) - 1.
		shiftWord _ destinationWord.
		1 to: pixPerWord do:
			[:i |
			mapIndex _ shiftWord bitAnd: pixMask.
			interpreterProxy storeWord: mapIndex ofObject: colorMap
				withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1.
			shiftWord _ shiftWord >> destPixSize].
		^ destinationWord].
	destPixSize = 16 ifTrue:
		["Two pixels  Tally the right half..."
		mapIndex _ self rgbMap: (destinationWord bitAnd: 16rFFFF) from: 5 to: cmBitsPerColor.
		interpreterProxy storeWord: mapIndex ofObject: colorMap
			withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1.
		"... and then left half"
		mapIndex _ self rgbMap: destinationWord>>16 from: 5 to: cmBitsPerColor.
		interpreterProxy storeWord: mapIndex ofObject: colorMap
			withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1]
	ifFalse:
		["Just one pixel."
		mapIndex _ self rgbMap: destinationWord from: 8 to: cmBitsPerColor.
		interpreterProxy storeWord: mapIndex ofObject: colorMap
			withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1].
	^ destinationWord  "For no effect on dest"! !


!BitBltSimulation methodsFor: 'pixel mapping'!
deltaFrom: x1 to: x2 nSteps: n
	"Utility routine for computing Warp increments."

	x2 > x1
		ifTrue: [^ x2 - x1 + FixedPt1 // (n+1) + 1]
		ifFalse: [x2 = x1 ifTrue: [^ 0].
				^ 0 - (x1 - x2 + FixedPt1 // (n+1) + 1)]! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:45'!
pickSourcePixels: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask
	"This is intended to be expanded in-line; it merely calls the others"
	self inline: true.
	sourcePixSize >= 16 ifTrue:
		[^ self pickSourcePixelsRGB: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask].
	nullMap ifTrue:
		[^ self pickSourcePixelsNullMap: nPix srcMask: sourcePixMask destMask: destPixMask].
	^ self pickSourcePixels: nPix srcMask: sourcePixMask destMask: destPixMask! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:46'!
pickSourcePixels: nPix srcMask: sourcePixMask destMask: destPixMask
	"This version of pickSourcePixels is for sourcePixSize <= 8
		and colorMap notNil"
	"Pick nPix pixels from the source, mapped by the
	color map, and right-justify them in the resulting destWord."
	| sourceWord destWord sourcePix destPix |
	self inline: false.
	sourceWord _ (interpreterProxy longAt: sourceIndex).
	destWord _ 0.
	1 to: nPix do:
		[:i |
		sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)
					bitAnd: sourcePixMask.
		"look up sourcePix in colorMap"
		destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask.
		destWord _ (destWord << destPixSize) bitOr: destPix.
		(srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:
			[srcBitIndex _ srcBitIndex - 32.
			sourceIndex _ sourceIndex + 4.
			sourceWord _ interpreterProxy longAt: sourceIndex]].
	^ destWord! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:46'!
pickSourcePixelsNullMap: nPix srcMask: sourcePixMask destMask: destPixMask
	"This version of pickSourcePixels is for colorMap==nil.
		SourcePixelSize is also known to be 8 bits or less."
	"With no color map, pixels are just masked or zero-filled."
	| sourceWord destWord sourcePix |
	self inline: false.
	sourceWord _ (interpreterProxy longAt: sourceIndex).
	destWord _ 0.
	1 to: nPix do:
		[:i |
		sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)
					bitAnd: sourcePixMask.
		destWord _ (destWord << destPixSize) 
					bitOr: (sourcePix bitAnd: destPixMask).
		(srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:
			[srcBitIndex _ srcBitIndex - 32.
			sourceIndex _ sourceIndex + 4.
			sourceWord _ interpreterProxy longAt: sourceIndex]].
	^ destWord! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:46'!
pickSourcePixelsRGB: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask
	"This version of pickSourcePixels is for sourcePixSize >= 16"
	"Pick nPix pixels from the source, mapped by the
	color map, and right-justify them in the resulting destWord.
	Incoming pixels of 16 or 32 bits are first reduced to cmBitsPerColor.
	With no color map, pixels are just masked or zero-filled or
	if 16- or 32-bit pixels, the r, g, and b are so treated individually."
	| sourceWord destWord sourcePix destPix |
	self inline: false.
	sourceWord _ (interpreterProxy longAt: sourceIndex).
	destWord _ 0.
	1 to: nPix do:
		[:i |
		sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)
					bitAnd: sourcePixMask.
		nullMap
		ifTrue:
			["Map between RGB pixels"
			sourcePixSize = 16
				ifTrue: [destPix _ self rgbMap: sourcePix from: 5 to: 8]
				ifFalse: [destPix _ self rgbMap: sourcePix from: 8 to: 5]]
		ifFalse:
			["RGB pixels first get reduced to cmBitsPerColor"
			sourcePixSize = 16
				ifTrue: [sourcePix _ self rgbMap: sourcePix from: 5 to: cmBitsPerColor]
				ifFalse: [sourcePix _ self rgbMap: sourcePix from: 8 to: cmBitsPerColor].
			"Then look up sourcePix in colorMap"
			destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask].
		destWord _ (destWord << destPixSize) bitOr: destPix.
		(srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:
			[srcBitIndex _ srcBitIndex - 32.
			sourceIndex _ sourceIndex + 4.
			sourceWord _ interpreterProxy longAt: sourceIndex]].
	^ destWord! !

!BitBltSimulation methodsFor: 'pixel mapping'!
rgbMap: sourcePixel from: nBitsIn to: nBitsOut
	"Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8."
	| mask d srcPix destPix |
	self inline: true.
	(d _ nBitsOut - nBitsIn) > 0
		ifTrue:
			["Expand to more bits by zero-fill"
			mask _ (1 << nBitsIn) - 1.  "Transfer mask"
			srcPix _ sourcePixel << d.
			mask _ mask << d.
			destPix _ srcPix bitAnd: mask.
			mask _ mask << nBitsOut.
			srcPix _ srcPix << d.
			^ destPix + (srcPix bitAnd: mask)
				 	+ (srcPix << d bitAnd: mask << nBitsOut)]
		ifFalse:
			["Compress to fewer bits by truncation"
			d = 0 ifTrue: [^ sourcePixel].  "no compression"
			sourcePixel = 0 ifTrue: [^ sourcePixel].  "always map 0 (transparent) to 0"
			d _ nBitsIn - nBitsOut.
			mask _ (1 << nBitsOut) - 1.  "Transfer mask"
			srcPix _ sourcePixel >> d.
			destPix _ srcPix bitAnd: mask.
			mask _ mask << nBitsOut.
			srcPix _ srcPix >> d.
			destPix _ destPix + (srcPix bitAnd: mask)
					+ (srcPix >> d bitAnd: mask << nBitsOut).
			destPix = 0 ifTrue: [^ 1].  "Dont fall into transparent by truncation"
			^ destPix]! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:07'!
smoothPix: n atXf: xf yf: yf dxh: dxh dyh: dyh dxv: dxv dyv: dyv
	pixPerWord: srcPixPerWord pixelMask: sourcePixMask
	sourceMap: sourceMap
	| sourcePix r g b x y rgb bitsPerColor d nPix maxPix |
	self inline: false.
	r _ g _ b _ 0.  "Separate r, g, b components"
	maxPix _ n*n.
	x _ xf.  y _ yf.
	nPix _ 0.  "actual number of pixels (not clipped and not transparent)"
	0 to: n-1 do:
		[:i |
		0 to: n-1 do:
			[:j |
			sourcePix _ (self sourcePixAtX: x + (dxh*i) + (dxv*j)  >> BinaryPoint
									y: y + (dyh*i) + (dyv*j)  >> BinaryPoint
									pixPerWord: srcPixPerWord)
									bitAnd: sourcePixMask.
			(combinationRule=25 "PAINT" and: [sourcePix = 0]) ifFalse:  
			["If not clipped and not transparent, then tally rgb values"
			nPix _ nPix + 1.
			sourcePixSize < 16
				ifTrue: ["Get 24-bit RGB values from sourcemap table"
						rgb _ (interpreterProxy fetchWord: sourcePix ofObject: sourceMap) bitAnd: 16rFFFFFF]
				ifFalse: ["Already in RGB format"
						sourcePixSize = 32
						ifTrue: [rgb _ sourcePix bitAnd: 16rFFFFFF]
						ifFalse: ["Note could be faster"
								rgb _ self rgbMap: sourcePix from: 5 to: 8]].
			r _ r + ((rgb >> 16) bitAnd: 16rFF).
			g _ g + ((rgb >> 8) bitAnd: 16rFF).
			b _ b + (rgb bitAnd: 16rFF).
			]].
		].
	(nPix = 0 or: [combinationRule=25 "PAINT" and: [nPix < (maxPix//2)]])
		ifTrue: [^ 0  "All pixels were 0, or most were transparent"].
	colorMap ~= interpreterProxy nilObject
		ifTrue: [bitsPerColor _ cmBitsPerColor]
		ifFalse: [destPixSize = 16 ifTrue: [bitsPerColor _ 5].
				destPixSize = 32 ifTrue: [bitsPerColor _ 8]].
	d _ 8 - bitsPerColor.
	rgb _ ((r // nPix >> d) << (bitsPerColor*2))
		+ ((g // nPix >> d) << bitsPerColor)
		+ ((b // nPix >> d)).
	rgb = 0 ifTrue: [
		"only generate zero if pixel is really transparent"
		(r + g + b) > 0 ifTrue: [rgb _ 1]].
	colorMap ~= interpreterProxy nilObject
		ifTrue: [^ interpreterProxy fetchWord: rgb ofObject: colorMap]
		ifFalse: [^ rgb]
! !

!BitBltSimulation methodsFor: 'pixel mapping'!
sourcePixAtX: x y: y pixPerWord: srcPixPerWord
	| sourceWord index |
	self inline: true.
	(x < 0 or: [x >= srcWidth]) ifTrue: [^ 0].
	(y < 0 or: [y >= srcHeight]) ifTrue: [^ 0].
	index _ (y * sourceRaster + (x // srcPixPerWord) *4).
												"4 = BaseHeaderSize"
	sourceWord _ interpreterProxy longAt: sourceBits + 4 + index.
	^ sourceWord >> ((32-sourcePixSize) - (x\\srcPixPerWord*sourcePixSize))! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:10'!
warpSourcePixels: nPix xDeltah: xDeltah yDeltah: yDeltah
	xDeltav: xDeltav yDeltav: yDeltav
	smoothing: n sourceMap: sourceMapOop
	"Pick nPix pixels using these x- and y-incs, and map color if necess."

	| destWord sourcePix sourcePixMask destPixMask srcPixPerWord destPix |
	self inline: false.
	sourcePixSize = 32
		ifTrue: [ sourcePixMask _ -1]
		ifFalse: [ sourcePixMask _ (1 << sourcePixSize) - 1].
	destPixSize = 32
		ifTrue: [ destPixMask _ -1]
		ifFalse: [ destPixMask _ (1 << destPixSize) - 1].
	srcPixPerWord _ 32 // sourcePixSize.
	destWord _ 0.
	1 to: nPix do:
		[:i |
		n > 1
		ifTrue:
			["Average n pixels and compute dest pixel from color map"
			destPix _ (self smoothPix: n atXf: sx yf: sy
				dxh: xDeltah//n dyh: yDeltah//n dxv: xDeltav//n dyv: yDeltav//n
				pixPerWord: srcPixPerWord pixelMask: sourcePixMask
				sourceMap: sourceMapOop)
					bitAnd: destPixMask]
		ifFalse:
			["No smoothing -- just pick pixel and map if difft depths or color map supplied"
			sourcePix _ (self sourcePixAtX: sx >> BinaryPoint
									y: sy >> BinaryPoint
									pixPerWord: srcPixPerWord)
						bitAnd: sourcePixMask.
			colorMap = interpreterProxy nilObject
				ifTrue:
				[destPixSize = sourcePixSize
				ifTrue:
					[destPix _ sourcePix]
				ifFalse:
					[sourcePixSize >= 16 ifTrue:
						["Map between RGB pixels"
						sourcePixSize = 16
							ifTrue: [destPix _ self rgbMap: sourcePix from: 5 to: 8]
							ifFalse: [destPix _ self rgbMap: sourcePix from: 8 to: 5]]
					ifFalse: [destPix _ sourcePix bitAnd: destPixMask]]]
			ifFalse:
				[sourcePixSize >= 16 ifTrue:
					["RGB pixels first get reduced to cmBitsPerColor"
					sourcePixSize = 16
						ifTrue: [sourcePix _ self rgbMap: sourcePix from: 5 to: cmBitsPerColor]
						ifFalse: [sourcePix _ self rgbMap: sourcePix from: 8 to: cmBitsPerColor]].
				"Then look up sourcePix in colorMap"
				destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask]].
		destWord _ (destWord << destPixSize) bitOr: destPix.
		sx _ sx + xDeltah.
		sy _ sy + yDeltah.
		].
	^ destWord! !


!BitBltSimulation methodsFor: 'translation support' stamp: 'di 1/21/98 23:01'!
initBBOpTable
	self cCode: 'opTable[0+1] = (int)clearWordwith'.
	self cCode: 'opTable[1+1] = (int)bitAndwith'.
	self cCode: 'opTable[2+1] = (int)bitAndInvertwith'.
	self cCode: 'opTable[3+1] = (int)sourceWordwith'.
	self cCode: 'opTable[4+1] = (int)bitInvertAndwith'.
	self cCode: 'opTable[5+1] = (int)destinationWordwith'.
	self cCode: 'opTable[6+1] = (int)bitXorwith'.
	self cCode: 'opTable[7+1] = (int)bitOrwith'.
	self cCode: 'opTable[8+1] = (int)bitInvertAndInvertwith'.
	self cCode: 'opTable[9+1] = (int)bitInvertXorwith'.
	self cCode: 'opTable[10+1] = (int)bitInvertDestinationwith'.
	self cCode: 'opTable[11+1] = (int)bitOrInvertwith'.
	self cCode: 'opTable[12+1] = (int)bitInvertSourcewith'.
	self cCode: 'opTable[13+1] = (int)bitInvertOrwith'.
	self cCode: 'opTable[14+1] = (int)bitInvertOrInvertwith'.
	self cCode: 'opTable[15+1] = (int)destinationWordwith'.
	self cCode: 'opTable[16+1] = (int)destinationWordwith'.
	self cCode: 'opTable[17+1] = (int)destinationWordwith'.
	self cCode: 'opTable[18+1] = (int)addWordwith'.
	self cCode: 'opTable[19+1] = (int)subWordwith'.
	self cCode: 'opTable[20+1] = (int)rgbAddwith'.
	self cCode: 'opTable[21+1] = (int)rgbSubwith'.
	self cCode: 'opTable[22+1] = (int)rgbDiffwith'.
	self cCode: 'opTable[23+1] = (int)tallyIntoMapwith'.
	self cCode: 'opTable[24+1] = (int)alphaBlendwith'.
	self cCode: 'opTable[25+1] = (int)pixPaintwith'.
	self cCode: 'opTable[26+1] = (int)pixMaskwith'.
	self cCode: 'opTable[27+1] = (int)rgbMaxwith'.
	self cCode: 'opTable[28+1] = (int)rgbMinwith'.
	self cCode: 'opTable[29+1] = (int)rgbMinInvertwith'.
	self cCode: 'opTable[30+1] = (int)destinationWordwith'.
	self cCode: 'opTable[31+1] = (int)destinationWordwith'.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitBltSimulation class
	instanceVariableNames: ''!

!BitBltSimulation class methodsFor: 'initialization'!
initialize
	"BitBltSimulation initialize"
 
	self initializeRuleTable.

	"Mask constants"
	AllOnes _ 16rFFFFFFFF.
	BinaryPoint _ 14.
	FixedPt1 _ 1 << BinaryPoint.  "Value of 1.0 in Warp's fixed-point representation"
 
	"Indices into stopConditions for scanning"
	EndOfRun _ 257.
	CrossedX _ 258.
 
	"Form fields"
	FormBitsIndex _ 0.
	FormWidthIndex _ 1.
	FormHeightIndex _ 2.
	FormDepthIndex _ 3.
 
	"BitBlt fields"
	BBDestFormIndex _ 0.
	BBSourceFormIndex _ 1.
	BBHalftoneFormIndex _ 2.
	BBRuleIndex _ 3.
	BBDestXIndex _ 4.
	BBDestYIndex _ 5.
	BBWidthIndex _ 6.
	BBHeightIndex _ 7.
	BBSourceXIndex _ 8.
	BBSourceYIndex _ 9.
	BBClipXIndex _ 10.
	BBClipYIndex _ 11.
	BBClipWidthIndex _ 12.
	BBClipHeightIndex _ 13.
	BBColorMapIndex _ 14.
	BBWarpBase _ 15.
	BBLastIndex _ 15.
	BBXTableIndex _ 16.! !

!BitBltSimulation class methodsFor: 'initialization' stamp: 'di 1/21/98 21:54'!
initializeRuleTable
	"BitBltSimulation initializeRuleTable"
	OpTable _ #(
		"0" clearWord:with:
		"1" bitAnd:with:
		"2" bitAndInvert:with:
		"3" sourceWord:with:
		"4" bitInvertAnd:with:
		"5" destinationWord:with:
		"6" bitXor:with:
		"7" bitOr:with:
		"8" bitInvertAndInvert:with:
		"9" bitInvertXor:with:
		"10" bitInvertDestination:with:
		"11" bitOrInvert:with:
		"12" bitInvertSource:with:
		"13" bitInvertOr:with:
		"14" bitInvertOrInvert:with:
		"15" destinationWord:with:
		"16" destinationWord:with:
		"17" destinationWord:with:
		"18" addWord:with:
		"19" subWord:with:
		"20" rgbAdd:with:
		"21" rgbSub:with:
		"22" rgbDiff:with:
		"23" tallyIntoMap:with:
		"24" alphaBlend:with:
		"25" pixPaint:with:
		"26" pixMask:with:
		"27" rgbMax:with:
		"28" rgbMin:with:
		"29" rgbMinInvert:with:
		"30" destinationWord:with:
		"31" destinationWord:with:
	).
	OpTableSize _ OpTable size + 1.  "0-origin indexing"
! !

!BitBltSimulation class methodsFor: 'initialization'!
test2  "BitBltSimulation test2"
	| f |
	Display fillWhite: (0@0 extent: 300@140).
	1 to: 12 do:
		[:i | f _ (Form extent: i@5) fillBlack.
		0 to: 20 do:
			[:x | f displayOn: Display
					at: (x*13) @ (i*10)]]! !

!BitBltSimulation class methodsFor: 'initialization'!
timingTest: extent  "BitBltSimulation timingTest: 640@480"
	| f f2 map |
	f _ Form extent: extent depth: 8.
	f2 _ Form extent: extent depth: 8.
	map _ Bitmap new: 1 << f2 depth.
	^ Array with:
	(Time millisecondsToRun: [100 timesRepeat:
		[f fillWithColor: Color white]])
	with:
	(Time millisecondsToRun: [100 timesRepeat:
		[f copy: f boundingBox from: 0@0 in: f2 rule: Form over]])
	with:
	(Time millisecondsToRun: [100 timesRepeat:
		[f copyBits: f boundingBox from: f2 at: 0@0 colorMap: map]])! !


!BitBltSimulation class methodsFor: 'translation' stamp: 'di 12/29/97 20:00'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator var: 'opTable'
		declareC: 'int opTable[' , OpTableSize printString , ']'! !
BitBltSimulation subclass: #BitBltSimulator
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Squeak-Interpreter'!

!BitBltSimulator methodsFor: 'all' stamp: 'di 12/30/97 09:23'!
initBBOpTable
	opTable _ OpTable! !

!BitBltSimulator methodsFor: 'all' stamp: 'di 12/30/97 11:07'!
mergeFn: arg1 with: arg2
	^ self perform: (opTable at: combinationRule+1) with: arg1 with: arg2! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitBltSimulator class
	instanceVariableNames: ''!

!BitBltSimulator class methodsFor: 'translation' stamp: 'ikp 1/3/98 23:10'!
translate: fileName doInlining: inlineFlag
	"Time millisecondsToRun: [
		Interpreter translate: 'interp.c' doInlining: true.
		Smalltalk beep] 164760 167543 171826 174510"
	| cg |
	BitBltSimulation initialize.
	Interpreter initialize.
	ObjectMemory initialize.
	cg _ CCodeGenerator new initialize.
	cg addClass: BitBltSimulation.
	cg addClass: Interpreter.
	cg addClass: ObjectMemory.
	BitBltSimulation declareCVarsIn: cg.
	Interpreter declareCVarsIn: cg.
	ObjectMemory declareCVarsIn: cg.
	cg storeCodeOnFile: fileName doInlining: inlineFlag.! !
MouseMenuController subclass: #BitEditor
	instanceVariableNames: 'scale squareForm color transparent '
	classVariableNames: 'ColorButtons YellowButtonMenu YellowButtonMessages '
	poolDictionaries: ''
	category: 'Graphics-Editors'!
!BitEditor commentStamp: 'di 5/22/1998 16:32' prior: 0!
BitEditor comment:
'I am a bit-magnifying tool for editing small Forms directly on the display screen. I continue to be active until the user points outside of my viewing area.'!


!BitEditor methodsFor: 'initialize-release'!
initialize

	super initialize.
	self initializeYellowButtonMenu! !

!BitEditor methodsFor: 'initialize-release'!
release

	super release.
	squareForm release.
	squareForm _ nil! !


!BitEditor methodsFor: 'view access'!
view: aView

	super view: aView.
	scale _ aView transformation scale.	
	scale _ scale x rounded @ scale y rounded.
	squareForm _ Form extent: scale depth: aView model depth.
	squareForm fillBlack! !


!BitEditor methodsFor: 'basic control sequence'!
controlInitialize

	super controlInitialize.
	Cursor crossHair show! !

!BitEditor methodsFor: 'basic control sequence'!
controlTerminate

	Cursor normal show! !


!BitEditor methodsFor: 'control defaults'!
isControlActive

	^super isControlActive & sensor blueButtonPressed not 
		& sensor keyboardPressed not! !

!BitEditor methodsFor: 'control defaults'!
redButtonActivity
	| formPoint displayPoint |
	model depth = 1 ifTrue:
		["If this is just a black&white form, then set the color to be
		the opposite of what it was where the mouse was clicked"
		formPoint _ (view inverseDisplayTransform: sensor cursorPoint - (scale//2)) rounded.
		color _ 1-(view workingForm pixelValueAt: formPoint).
		squareForm fillColor: (color=1 ifTrue: [Color black] ifFalse: [Color white])].
	[sensor redButtonPressed]
	  whileTrue: 
		[formPoint _ (view inverseDisplayTransform: sensor cursorPoint - (scale//2)) rounded.
		displayPoint _ view displayTransform: formPoint.
		squareForm 
			displayOn: Display
			at: displayPoint 
			clippingBox: view insetDisplayBox 
			rule: Form over
			fillColor: nil.
		view changeValueAt: formPoint put: color]! !


!BitEditor methodsFor: 'menu messages'!
accept
	"The edited information should now be accepted by the view."

	view accept! !

!BitEditor methodsFor: 'menu messages'!
cancel
	"The edited informatin should be forgotten by the view."

	view cancel! !

!BitEditor methodsFor: 'menu messages' stamp: 'jm 3/27/98 14:52'!
fileOut

	| fileName |
	fileName _ FillInTheBlank
		request: 'File name?'
		initialAnswer: 'Filename.form'.
	fileName isEmpty ifTrue: [^ self].
	Cursor normal
		showWhile: [model writeOnFileNamed: fileName].
! !

!BitEditor methodsFor: 'menu messages'!
setColor: aColor
	"Set the color that the next edited dots of the model to be the argument, 
	aSymbol. aSymbol can be any color changing message understood by a 
	Form, such as white or black."

	color _ aColor pixelValueForDepth: model depth.
	squareForm fillColor: aColor.
! !

!BitEditor methodsFor: 'menu messages'!
setTransparentColor
	squareForm fillColor: Color gray.
	color _ model transparentPixelValue! !

!BitEditor methodsFor: 'menu messages'!
test
	view workingForm follow: [Sensor cursorPoint] while: [Sensor noButtonPressed].
	Sensor waitNoButton! !


!BitEditor methodsFor: 'private'!
initializeYellowButtonMenu

	self yellowButtonMenu: YellowButtonMenu
		yellowButtonMessages: YellowButtonMessages! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitEditor class
	instanceVariableNames: ''!

!BitEditor class methodsFor: 'class initialization'!
initialize
	"The Bit Editor is the only controller to override the use of the blue
	button with a different pop-up menu. Initialize this menu."

	YellowButtonMenu _ PopUpMenu labels:
'cancel
accept
file out
test' lines: #(2 3).
	YellowButtonMessages _ #(cancel accept fileOut test)	

	"BitEditor initialize"! !


!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm 
	"Create and schedule a BitEditor on the form aForm at its top left corner. 
	Show the small and magnified view of aForm."

	| scaleFactor |
	scaleFactor _ 8 @ 8.
	^self openOnForm: aForm
		at: (self locateMagnifiedView: aForm scale: scaleFactor) topLeft
		scale: scaleFactor! !

!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm at: magnifiedLocation 
	"Create and schedule a BitEditor on the form aForm at magnifiedLocation. 
	Show the small and magnified view of aForm."

	^self openOnForm: aForm
		at: magnifiedLocation
		scale: 8 @ 8! !

!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm at: magnifiedLocation scale: scaleFactor 
	"Create and schedule a BitEditor on the form aForm. Show the small and 
	magnified view of aForm."

	| aScheduledView |
	aScheduledView _ self
				bitEdit: aForm
				at: magnifiedLocation
				scale: scaleFactor
				remoteView: nil.
	aScheduledView controller openDisplayAt:
		aScheduledView displayBox topLeft + (aScheduledView displayBox extent / 2)! !

!BitEditor class methodsFor: 'instance creation'!
openScreenViewOnForm: aForm at: formLocation magnifiedAt: magnifiedLocation scale: scaleFactor
	"Create and schedule a BitEditor on the form aForm. Show the magnified
	view of aForm in a scheduled window."
	| smallFormView bitEditor savedForm r |
	smallFormView _ FormView new model: aForm.
	smallFormView align: smallFormView viewport topLeft with: formLocation.
	bitEditor _ self bitEdit: aForm at: magnifiedLocation scale: scaleFactor remoteView: smallFormView.
	bitEditor controller blueButtonMenu: nil blueButtonMessages: nil.
	savedForm _ Form fromDisplay: (r _ bitEditor displayBox expandBy: (0@23 corner: 0@0)).
	bitEditor controller startUp.
	savedForm displayOn: Display at: r topLeft.
	bitEditor release.
	smallFormView release.

	"BitEditor magnifyOnScreen."! !


!BitEditor class methodsFor: 'examples'!
magnifyOnScreen
	"Bit editing of an area of the display screen. User designates a 
	rectangular area that is magnified by 8 to allow individual screens dots to
	be modified. red button is used to set a bit to black and yellow button is
	used to set a bit to white. Editor is not scheduled in a view. Original
	screen location is updated immediately. This is the same as FormEditor
	magnify."
	| smallRect smallForm scaleFactor tempRect |
	scaleFactor _ 8 @ 8.
	smallRect _ Rectangle fromUser.
	smallRect isNil ifTrue: [^self].
	smallForm _ Form fromDisplay: smallRect.
	tempRect _ self locateMagnifiedView: smallForm scale: scaleFactor.
	"show magnified form size until mouse is depressed"
	self
		openScreenViewOnForm: smallForm 
		at: smallRect topLeft 
		magnifiedAt: tempRect topLeft 
		scale: scaleFactor

	"BitEditor magnifyOnScreen."! !

!BitEditor class methodsFor: 'examples'!
magnifyWithSmall
"	Also try:
	BitEditor openOnForm:
		(Form extent: 32@32 depth: Display depth)
	BitEditor openOnForm:
		((MaskedForm extent: 32@32 depth: Display depth)
		withTransparentPixelValue: -1)
"
	"Open a BitEditor viewing an area on the screen which the user chooses"
	| area form |
	area _ Rectangle fromUser.
	area isNil ifTrue: [^ self].
	form _ Form fromDisplay: area.
	self openOnForm: form

	"BitEditor magnifyWithSmall."! !


!BitEditor class methodsFor: 'private' stamp: 'di 1/16/98 15:46'!
bitEdit: aForm at: magnifiedFormLocation scale: scaleFactor remoteView: remoteView
	"Create a BitEditor on aForm. That is, aForm is a small image that will 
	change as a result of the BitEditor changing a second and magnified 
	view of me. magnifiedFormLocation is where the magnified form is to be 
	located on the screen. scaleFactor is the amount of magnification. This 
	method implements a scheduled view containing both a small and 
	magnified view of aForm. Upon accept, aForm is updated."

	| aFormView scaledFormView bitEditor topView extent menuView lowerRightExtent |
	scaledFormView _ FormHolderView new model: aForm.
	scaledFormView scaleBy: scaleFactor.
	bitEditor _ self new.
	scaledFormView controller: bitEditor.
	bitEditor setColor: Color black.
	topView _ StandardSystemView new.
	remoteView == nil ifTrue: [topView label: 'Bit Editor'].
	topView borderWidth: 2.

	topView addSubView: scaledFormView.
	remoteView == nil
		ifTrue:  "If no remote view, then provide a local view of the form"
			[aFormView _ FormView new model: scaledFormView workingForm.
			aFormView controller: NoController new.
			aForm height < 50
				ifTrue: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 2]
				ifFalse: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 0].
			topView addSubView: aFormView below: scaledFormView]
		 ifFalse:  "Otherwise, the remote one should view the same form"
			[remoteView model: scaledFormView workingForm].
	lowerRightExtent _ remoteView == nil
			ifTrue:
				[(scaledFormView viewport width - aFormView viewport width) @
					(aFormView viewport height max: 50)]
			ifFalse:
				[scaledFormView viewport width @ 50].
	menuView _ self buildColorMenu: lowerRightExtent colorCount: 1.
	menuView model: bitEditor.
	menuView borderWidthLeft: 0 right: 0 top: 2 bottom: 0.
	topView
		addSubView: menuView
		align: menuView viewport topRight
		with: scaledFormView viewport bottomRight.
	extent _ scaledFormView viewport extent + (0 @ lowerRightExtent y)
			+ (4 @ 4).  "+4 for borders"
	topView minimumSize: extent.
	topView maximumSize: extent.
	topView translateBy: magnifiedFormLocation.
	topView insideColor: Color white.
	^topView! !

!BitEditor class methodsFor: 'private' stamp: 'jm 4/7/98 20:43'!
buildColorMenu: extent colorCount: nColors
	"See BitEditor magnifyWithSmall."

	| menuView form aSwitchView
	 button formExtent highlightForm color leftOffset |
	menuView _ FormMenuView new.
	menuView window: (0@0 corner: extent).
	formExtent _ 30@30 min: extent//(nColors*2+1@2).  "compute this better"
	leftOffset _ extent x-(nColors*2-1*formExtent x)//2.
	highlightForm _ Form extent: formExtent.
	highlightForm borderWidth: 4.
	1 to: nColors do: [:index | 
		color _ (nColors = 1
			ifTrue: [#(black)]
			ifFalse: [#(black gray)]) at: index.
		form _ Form extent: formExtent.
		form fill: form boundingBox fillColor: (Color perform: color).
		form borderWidth: 5.
		form border: form boundingBox width: 4 fillColor: Color white.
		button _ Button new.
		index = 1
			ifTrue: [button onAction: [menuView model setColor: Color fromUser]]
			ifFalse: [button onAction: [menuView model setTransparentColor]].

		aSwitchView _ PluggableButtonView
			on: button
			getState: #isOn
			action: #turnOn.
		aSwitchView
			shortcutCharacter: ((nColors=3 ifTrue: ['xvn'] ifFalse: ['xn']) at: index);
			label: form;
			window: (0@0 extent: form extent);
			translateBy: (((index - 1) * 2 * form width) + leftOffset)@(form height // 2);
			borderWidth: 1.
		menuView addSubView: aSwitchView].
	^ menuView
! !

!BitEditor class methodsFor: 'private'!
locateMagnifiedView: aForm scale: scaleFactor
	"Answer a rectangle at the location where the scaled view of the form,
	aForm, should be displayed."

	^ Rectangle originFromUser: (aForm extent * scaleFactor + (0@50)).
	! !
ArrayedCollection variableWordSubclass: #Bitmap
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Support'!
!Bitmap commentStamp: 'di 5/22/1998 16:32' prior: 0!
Bitmap comment:
'My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.'!


!Bitmap methodsFor: 'initialize-release'!
fromByteStream: aStream 
	"Initialize the array of bits by reading integers from the argument, 
	aStream."
	aStream nextInto: self! !


!Bitmap methodsFor: 'filing' stamp: 'di 2/19/98 17:03'!
compress: bm toByteArray: ba
	"Store a run-coded compression of the receiver into the byteArray ba,
	and return the last index stored into. ba is assumed to be large enough.
	The encoding is as follows...
		S {N D}*.
		S is the size of the original bitmap, followed by run-coded pairs.
		N is a run-length * 4 + data code.
		D, the data, depends on the data code...
			0	skip N words, D is absent
			1	N words with all 4 bytes = D (1 byte)
			2	N words all = D (4 bytes)
			3	N words follow in D (4N bytes)
		S and N are encoded as follows...
			0-223	0-223
			224-254	(0-30)*256 + next byte (0-7935)
			255		next 4 bytes"		
	| size k word j lowByte eqBytes i |
	<primitive: 237>
	self var: #bm declareC: 'int *bm'.
	self var: #ba declareC: 'unsigned char *ba'.
	size _ bm size.
	i _ self encodeInt: size in: ba at: 1.
	k _ 1.
	[k <= size] whileTrue:
		[word _ bm at: k.
		lowByte _ word bitAnd: 16rFF.
		eqBytes _ ((word >> 8) bitAnd: 16rFF) = lowByte
				and: [((word >> 16) bitAnd: 16rFF) = lowByte
				and: [((word >> 24) bitAnd: 16rFF) = lowByte]].
		j _ k.
		[j < size and: [word = (bm at: j+1)]]  "scan for = words..."
			whileTrue: [j _ j+1].
		j > k ifTrue:
			["We have two or more = words, ending at j"
			eqBytes
				ifTrue: ["Actually words of = bytes"
						i _ self encodeInt: j-k+1*4+1 in: ba at: i.
						ba at: i put: lowByte.  i _ i+1]
				ifFalse: [i _ self encodeInt: j-k+1*4+2 in: ba at: i.
						i _ self encodeBytesOf: word in: ba at: i].
			k _ j+1]
			ifFalse:
			["Check for word of 4 = bytes"
			eqBytes ifTrue:
				["Note 1 word of 4 = bytes"
				i _ self encodeInt: 1*4+1 in: ba at: i.
				ba at: i put: lowByte.  i _ i+1.
				k _ k + 1]
				ifFalse:
				["Finally, check for junk"
				[j < size and: [(bm at: j) ~= (bm at: j+1)]]  "scan for ~= words..."
					whileTrue: [j _ j+1].
				j = size ifTrue: [j _ j + 1].
				"We have one or more unmatching words, ending at j-1"
				i _ self encodeInt: j-k*4+3 in: ba at: i.
				k to: j-1 do:
					[:m | i _ self encodeBytesOf: (bm at: m) in: ba at: i].
				k _ j]]].
	^ i - 1  "number of bytes actually stored"
"
Space check:
 | n rawBytes myBytes b |
n _ rawBytes _ myBytes _ 0.
Form allInstancesDo:
	[:f | b _ f bits.
	n _ n + 1.
	rawBytes _ rawBytes + (b size*4).
	myBytes _ myBytes + (b compressToByteArray size)].
Array with: n with: rawBytes with: myBytes
ColorForms: (116 230324 160318 )
Forms: (113 1887808 1325055 )

Integerity check:
Form allInstances do:
	[:f | f bits = (Bitmap decompressFromByteArray: f bits compressToByteArray)
		ifFalse: [self halt]]

Speed test:
MessageTally spyOn: [Form allInstances do:
	[:f | Bitmap decompressFromByteArray: f bits compressToByteArray]]
"! !

!Bitmap methodsFor: 'filing' stamp: 'di 2/19/98 16:59'!
compressToByteArray
	"Return a run-coded compression of this bitmap into a byteArray"		
	| byteArray lastByte |
	"Without skip codes, it is unlikely that the compressed bitmap will be any larger than was the original.  The run-code cases are...
	N >= 1 words of equal bytes:  4N bytes -> 2 bytes (at worst 4 -> 2)
	N > 1 equal words:  4N bytes -> 5 bytes (at worst 8 -> 5)
	N > 1 unequal words:  4N bytes -> 4N + M, where M is the number of bytes required to encode the run length.

The worst that can happen is that the method begins with unequal words, and than has interspersed occurrences of a word with equal bytes.  Thus we require a run-length at the beginning, and after every interspersed word of equal bytes.  However, each of these saves 2 bytes, so it must be followed by a run of 7936 or more (for which M jumps from 2 to 5) to add any extra overhead.  Therefore the worst case is a series of runs of 7936 or more, with single interspersed words of equal bytes.  At each break we save 2 bytes, but add 5.  Thus the overhead would be no more than 5 + (S//7936*3)."
	
	byteArray _ ByteArray new: (self size*4) + 5 + (self size//7936*3).
	lastByte _ self compress: self toByteArray: byteArray.
	^ byteArray copyFrom: 1 to: lastByte! !

!Bitmap methodsFor: 'filing' stamp: 'di 2/19/98 17:13'!
decompress: bm fromByteArray: ba at: index
	"Decompress the body of a byteArray encoded by compressToByteArray (qv)...
	The format is simply a sequence of run-coded pairs, {N D}*.
		N is a run-length * 4 + data code.
		D, the data, depends on the data code...
			0	skip N words, D is absent
				(could be used to skip from one raster line to the next)
			1	N words with all 4 bytes = D (1 byte)
			2	N words all = D (4 bytes)
			3	N words follow in D (4N bytes)
		S and N are encoded as follows (see decodeIntFrom:)...
			0-223	0-223
			224-254	(0-30)*256 + next byte (0-7935)
			255		next 4 bytes"	
	"NOTE:  If fed with garbage, this routine could read past the end of ba, but it should fail before writing past the ned of bm."
	| i code n anInt data end k pastEnd |
	<primitive: 234>
	self var: #bm declareC: 'int *bm'.
	self var: #ba declareC: 'unsigned char *ba'.
	i _ index.  "byteArray read index"
	end _ ba size.
	k _ 1.  "bitmap write index"
	pastEnd _ bm size + 1.
	[i <= end] whileTrue:
		["Decode next run start N"
		anInt _ ba at: i.  i _ i+1.
		anInt <= 223 ifFalse:
			[anInt <= 254
				ifTrue: [anInt _ (anInt-224)*256 + (ba at: i).  i _ i+1]
				ifFalse: [anInt _ 0.
						1 to: 4 do: [:j | anInt _ (anInt bitShift: 8) + (ba at: i).  i _ i+1]]].
		n _ anInt >> 2.
		(k + n) > pastEnd ifTrue: [^ self primitiveFail].
		code _ anInt bitAnd: 3.
		code = 0 ifTrue: ["skip"].
		code = 1 ifTrue: ["n consecutive words of 4 bytes = the following byte"
						data _ ba at: i.  i _ i+1.
						data _ data bitOr: (data bitShift: 8).
						data _ data bitOr: (data bitShift: 16).
						1 to: n do: [:j | bm at: k put: data.  k _ k+1]].
		code = 2 ifTrue: ["n consecutive words = 4 following bytes"
						data _ 0.
						1 to: 4 do: [:j | data _ (data bitShift: 8) bitOr: (ba at: i).  i _ i+1].
						1 to: n do: [:j | bm at: k put: data.  k _ k+1]].
		code = 3 ifTrue: ["n consecutive words from the data..."
						1 to: n do:
							[:m | data _ 0.
							1 to: 4 do: [:j | data _ (data bitShift: 8) bitOr: (ba at: i).  i _ i+1].
							bm at: k put: data.  k _ k+1]]]! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:27'!
encodeBytesOf: anInt in: ba at: i
	"Copy the integer anInt into byteArray ba at index i, and return the next index"

	self inline: true.
	self var: #ba declareC: 'unsigned char *ba'.
	0 to: 3 do:
		[:j | ba at: i+j put: (anInt >> (3-j*8) bitAnd: 16rFF)].
	^ i+4! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/12/98 17:32'!
encodeInt: int
	"Encode the integer int as per encodeInt:in:at:, and return it as a ByteArray"
	| byteArray next |
	byteArray _ ByteArray new: 5.
	next _ self encodeInt: int in: byteArray at: 1.
	^ byteArray copyFrom: 1 to: next - 1
! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:26'!
encodeInt: anInt in: ba at: i
	"Encode the integer anInt in byteArray ba at index i, and return the next index.
	The encoding is as follows...
		0-223	0-223
		224-254	(0-30)*256 + next byte (0-7935)
		255		next 4 bytes"		

	self inline: true.
	self var: #ba declareC: 'unsigned char *ba'.
	anInt <= 223 ifTrue: [ba at: i put: anInt. ^ i+1].
	anInt <= 7935 ifTrue: [ba at: i put: anInt//256+224. ba at: i+1 put: anInt\\256.  ^ i+2].
	ba at: i put: 255.
	^ self encodeBytesOf: anInt in: ba at: i+1! !

!Bitmap methodsFor: 'filing' stamp: 'di 2/11/98 21:34'!
readCompressedFrom: strm
	"Decompress an old-style run-coded stream into this bitmap:
		[0 means end of runs]
		[n = 1..127] [(n+3) copies of next byte]
		[n = 128..191] [(n-127) next bytes as is]
		[n = 192..255] [(n-190) copies of next 4 bytes]"
	| n byte out outBuff bytes |
	out _ WriteStream on: (outBuff _ ByteArray new: self size*4).
	[(n _ strm next) > 0] whileTrue:
		[(n between: 1 and: 127) ifTrue:
			[byte _ strm next.
			1 to: n+3 do: [:i | out nextPut: byte]].
		(n between: 128 and: 191) ifTrue:
			[1 to: n-127 do: [:i | out nextPut: strm next]].
		(n between: 192 and: 255) ifTrue:
			[bytes _ (1 to: 4) collect: [:i | strm next].
			1 to: n-190 do: [:i | bytes do: [:b | out nextPut: b]]]].
	out position = outBuff size ifFalse: [self error: 'Decompression size error'].
	"Copy the final byteArray into self"
	self copyFromByteArray: outBuff.! !

!Bitmap methodsFor: 'filing' stamp: 'di 10/2/97 00:02'!
swapBytesFrom: start to: stop
	"Perform a bigEndian/littleEndian byte reversal of my words"
	| hack blt |
	"The implementation is a hack, but fast for large ranges"
	hack _ Form new hackBits: self.
	blt _ (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.  "XOR"
	blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1.
	blt sourceX: 0; destX: 3; copyBits.  "Exchange bytes 0 and 3"
	blt sourceX: 3; destX: 0; copyBits.
	blt sourceX: 0; destX: 3; copyBits.
	blt sourceX: 1; destX: 2; copyBits.  "Exchange bytes 1 and 2"
	blt sourceX: 2; destX: 1; copyBits.
	blt sourceX: 1; destX: 2; copyBits.
! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/18/98 14:19'!
writeOn: aStream 
	"Store the array of bits onto the argument, aStream. A leading byte of 16r80 identifies this as compressed by compressToByteArray (qv)."

	| b |
	aStream nextPut: 16r80.
	b _ self compressToByteArray.
	aStream
		nextPutAll: (self encodeInt: b size);
		nextPutAll: b.
! !


!Bitmap methodsFor: 'printing'!
printOn: aStream

	aStream nextPutAll: 'a Bitmap of length '.
	self size printOn: aStream! !


!Bitmap methodsFor: 'accessing'!
bitPatternForDepth: depth
	"The raw call on BitBlt needs a Bitmap to represent this color.  I already am Bitmap like.  I am already adjusted for a specific depth.  Interpret me as an array of (32/depth) Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk"

	^ self! !

!Bitmap methodsFor: 'accessing'!
byteAt: byteAddress
	"Extract a byte from a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:.  See Form pixelAt:  7/1/96 tk"
	| lowBits |
	lowBits _ byteAddress - 1 bitAnd: 3.
	^((self at: byteAddress - 1 - lowBits // 4 + 1)
		bitShift: (lowBits - 3) * 8)
		bitAnd: 16rFF! !

!Bitmap methodsFor: 'accessing'!
byteAt: byteAddress put: byte
	"Insert a byte into a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:put:.  See Form pixelAt:put:  7/1/96 tk"

	| longWord shift lowBits longAddr |
	lowBits _ byteAddress - 1 bitAnd: 3.
	longWord _ self at: (longAddr _ (byteAddress - 1 - lowBits) // 4 + 1).
	shift _ (3 - lowBits) * 8.
	longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) 
		+ (byte bitShift: shift).
	self at: longAddr put: longWord.
	^ byte! !

!Bitmap methodsFor: 'accessing' stamp: 'di 10/4/97 11:56'!
copyFromByteArray: byteArray
	"This method should work with either byte orderings"
	| long |
	(self size * 4) = byteArray size ifFalse: [self halt].
	1 to: byteArray size by: 4 do:
		[:i | long _ Integer
				byte1: (byteArray at: i+3)
				byte2: (byteArray at: i+2)
				byte3: (byteArray at: i+1)
				byte4: (byteArray at: i).
		self at: i+3//4 put: long]! !

!Bitmap methodsFor: 'accessing' stamp: 'tk 3/15/97'!
pixelValueForDepth: depth
	"Self is being used to represent a single color.  Answer bits that appear in ONE pixel of this color in a Bitmap of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32.  Returns an integer.  First pixel only.  "

	^ (self at: 1) bitAnd: (1 bitShift: depth) - 1! !

!Bitmap methodsFor: 'accessing'!
primFill: aPositiveInteger
	"Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."

	<primitive: 145>
	self errorImproperStore.! !

!Bitmap methodsFor: 'accessing'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Bitmap class
	instanceVariableNames: ''!

!Bitmap class methodsFor: 'instance creation' stamp: 'di 2/9/98 16:02'!
decodeIntFrom: s
	"Decode an integer in stream s as follows...
		0-223	0-223
		224-254	(0-30)*256 + next byte (0-7935)
		255		next 4 bytes	"		
	| int |
	int _ s next.
	int <= 223 ifTrue: [^ int].
	int <= 254 ifTrue: [^ (int-224)*256 + s next].
	int _ s next.
	1 to: 3 do: [:j | int _ (int bitShift: 8) + s next].
	^ int! !

!Bitmap class methodsFor: 'instance creation' stamp: 'di 2/12/98 14:34'!
decompressFromByteArray: byteArray
	| s bitmap size |
	s _ ReadStream on: byteArray.
	size _ self decodeIntFrom: s.
	bitmap _ self new: size.
	bitmap decompress: bitmap fromByteArray: byteArray at: s position+1.
	^ bitmap! !

!Bitmap class methodsFor: 'instance creation' stamp: 'di 2/11/98 21:11'!
newFromStream: s
	| len |
	s next = 16r80 ifTrue:
		["New compressed format"
		len _ self decodeIntFrom: s.
		^ Bitmap decompressFromByteArray: (s nextInto: (ByteArray new: len))].
	s skip: -1.
	len _ s nextInt32.
	len <= 0
		ifTrue: ["Old compressed format"
				^ (self new: len negated) readCompressedFrom: s]
		ifFalse: ["Old raw data format"
				^ s nextInto: (self new: len)]! !
ContextPart variableSubclass: #BlockContext
	instanceVariableNames: 'nargs startpc home '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!BlockContext commentStamp: 'di 5/22/1998 16:32' prior: 0!
BlockContext comment:
'My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution.
	
My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity.'!


!BlockContext methodsFor: 'initialize-release'!
home: aContextPart startpc: position nargs: anInteger 
	"This is the initialization message. The receiver has been initialized with 
	the correct size only."

	home _ aContextPart.
	startpc _ position.
	nargs _ anInteger! !


!BlockContext methodsFor: 'accessing'!
fixTemps
	"Fix the values of the temporary variables used in the block that are 
	ordinarily shared with the method in which the block is defined."

	home _ home copy.
	home swapSender: nil! !

!BlockContext methodsFor: 'accessing'!
hasMethodReturn
	"Answer whether the receiver has a return ('^') in its code."

	| method scanner end |
	method _ self method.
	"Determine end of block from long jump preceding it"
	end _ (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1.
	scanner _ InstructionStream new method: method pc: startpc.
	scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]].
	^scanner pc <= end! !

!BlockContext methodsFor: 'accessing'!
home
	"Answer the context in which the receiver was defined."

	^home! !

!BlockContext methodsFor: 'accessing'!
method
	"Answer the compiled method in which the receiver was defined."

	^home method! !

!BlockContext methodsFor: 'accessing'!
numArgs

	^nargs! !

!BlockContext methodsFor: 'accessing'!
receiver 
	"Refer to the comment in ContextPart|receiver."

	^home receiver! !

!BlockContext methodsFor: 'accessing'!
tempAt: index 
	"Refer to the comment in ContextPart|tempAt:."

	^home at: index! !

!BlockContext methodsFor: 'accessing'!
tempAt: index put: value 
	"Refer to the comment in ContextPart|tempAt:put:."

	^home at: index put: value! !


!BlockContext methodsFor: 'evaluating' stamp: 'jm 2/19/98 13:19'!
ifError: errorHandlerBlock
	"Evaluate the block represented by the receiver. If an error occurs the given is evaluated with the error message and the receiver as parameters. The error handler block may return a value to be used if the receiver block gets an error. The receiver should not contain an explicit return statement as this would leave an obsolete error handler hanging around."
	"Examples:
		[1 whatsUpDoc] ifError: [:err :rcvr | ^ 'huh?'].
		[1 / 0] ifError: [:err :rcvr |
			'division by 0' = err
				ifTrue: [^ Float inf]
				ifFalse: [self error: err]]
"

	| lastHandler val activeProcess |
	activeProcess _ Processor activeProcess.
	lastHandler _ activeProcess errorHandler.
	activeProcess errorHandler: [:aString :aReceiver |
		activeProcess errorHandler: lastHandler.
		^ errorHandlerBlock value: aString value: aReceiver].
	val _ self value.
	activeProcess errorHandler: lastHandler.
	^ val
! !

!BlockContext methodsFor: 'evaluating'!
value
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects any arguments or if the block is already being executed. 
	Optional. No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: #()! !

!BlockContext methodsFor: 'evaluating'!
value: arg 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than one argument or if the block is already being 
	executed. Optional. No Lookup. See Object documentation 
	whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: (Array with: arg)! !

!BlockContext methodsFor: 'evaluating'!
value: arg1 ifError: aBlock
	"Evaluate the block represented by the receiver. If an error occurs aBlock is evaluated
	 with the error message and the receiver as parameters. The receiver should not contain
	 an explicit return statement as this would leave an obsolete error handler hanging around."

	| lastHandler val activeProcess |
	activeProcess _ Processor activeProcess.
	lastHandler _ activeProcess errorHandler.
	activeProcess errorHandler: [:aString :aReceiver |
		activeProcess errorHandler: lastHandler.
		^ aBlock value: aString value: aReceiver].
	val _ self value: arg1.
	activeProcess errorHandler: lastHandler.
	^ val! !

!BlockContext methodsFor: 'evaluating'!
value: arg1 value: arg2 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than two arguments or if the block is already being 
	executed. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: (Array with: arg1 with: arg2)! !

!BlockContext methodsFor: 'evaluating'!
value: arg1 value: arg2 value: arg3 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than three arguments or if the block is already being 
	executed. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: 
		(Array
			with: arg1
			with: arg2
			with: arg3)! !

!BlockContext methodsFor: 'evaluating' stamp: 'di 11/30/97 09:19'!
value: arg1 value: arg2 value: arg3 value: arg4 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than three arguments or if the block is already being 
	executed. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: 
		(Array
			with: arg1
			with: arg2
			with: arg3
			with: arg4)! !

!BlockContext methodsFor: 'evaluating'!
valueWithArguments: anArray 
	"Primitive. Evaluate the block represented by the receiver. The argument 
	is an Array whose elements are the arguments for the block. Fail if the 
	length of the Array is not the same as the the number of arguments that 
	the block was expecting. Fail if the block is already being executed. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 82>
	self numArgs = anArray size
		ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.']
		ifFalse: [self error: 'This block requires ' , self numArgs printString , ' arguments.']! !


!BlockContext methodsFor: 'controlling'!
whileFalse
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the receiver, as long as its value is false."
 
	^ [self value] whileFalse: []! !

!BlockContext methodsFor: 'controlling'!
whileFalse: aBlock 
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the argument, aBlock, as long as the value of the receiver is false."

	^ [self value] whileFalse: [aBlock value]! !

!BlockContext methodsFor: 'controlling'!
whileTrue
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the receiver, as long as its value is true."
 
	^ [self value] whileTrue: []! !

!BlockContext methodsFor: 'controlling'!
whileTrue: aBlock 
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the argument, aBlock, as long as the value of the receiver is true."

	^ [self value] whileTrue: [aBlock value]! !


!BlockContext methodsFor: 'scheduling'!
fork
	"Create and schedule a Process running the code in the receiver."

	self newProcess resume! !

!BlockContext methodsFor: 'scheduling'!
forkAt: priority 
	"Create and schedule a Process running the code in the receiver. The 
	priority of the process is the argument, priority."

	| forkedProcess |
	forkedProcess _ self newProcess.
	forkedProcess priority: priority.
	forkedProcess resume! !

!BlockContext methodsFor: 'scheduling'!
newProcess
	"Answer a Process running the code in the receiver. The process is not 
	scheduled."

	^Process
		forContext: 
			[self value.
			Processor terminateActive]
		priority: Processor activePriority! !

!BlockContext methodsFor: 'scheduling'!
newProcessWith: anArray 
	"Answer a Process running the code in the receiver. The receiver's block 
	arguments are bound to the contents of the argument, anArray. The 
	process is not scheduled."

	^Process
		forContext: 
			[self valueWithArguments: anArray.
			Processor terminateActive]
		priority: Processor activePriority! !


!BlockContext methodsFor: 'instruction decoding'!
blockReturnTop
	"Simulate the interpreter's action when a ReturnTopOfStack bytecode is 
	encountered in the receiver."

	| save dest |
	save _ home.	"Needed because return code will nil it"
	dest _ self return: self pop to: self sender.
	home _ save.
	sender _ nil.
	^dest! !


!BlockContext methodsFor: 'printing'!
printOn: aStream

	home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil'].
	aStream nextPutAll: '[] in '.
	super printOn: aStream! !


!BlockContext methodsFor: 'private' stamp: 'tk 4/16/1998 15:38'!
cannotReturn: result
	"The receiver tried to return result to a method context that no longer exists."

	Debugger
		openContext: thisContext
		label: 'Block cannot return'
		contents: thisContext shortStack.
! !

!BlockContext methodsFor: 'private'!
startpc
	"for use by the System Tracer only"

	^startpc! !

!BlockContext methodsFor: 'private'!
valueError

	self error: 'Incompatible number of args, or already active'! !


!BlockContext methodsFor: 'system simulation'!
pushArgs: args from: sendr 
	"Simulates action of the value primitive."

	args size ~= nargs ifTrue: [^self error: 'incorrect number of args'].
	stackp _ 0.
	args do: [:arg | self push: arg].
	sender _ sendr.
	pc _ startpc! !
ParseNode subclass: #BlockNode
	instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!BlockNode commentStamp: 'di 5/22/1998 16:32' prior: 0!
BlockNode comment:
'I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.'!


!BlockNode methodsFor: 'initialize-release'!
arguments: argNodes statements: statementsCollection returns: returnBool from: encoder
	"Compile."

	arguments _ argNodes.
	statements _ statementsCollection size > 0
				ifTrue: [statementsCollection]
				ifFalse: [argNodes size > 0
						ifTrue: [statementsCollection copyWith: arguments last]
						ifFalse: [Array with: NodeNil]].
	returns _ returnBool! !

!BlockNode methodsFor: 'initialize-release'!
statements: statementsCollection returns: returnBool 
	"Decompile."

	| returnLast |
	returnLast _ returnBool.
	returns _ false.
	statements _ 
		(statementsCollection size > 1 
			and: [(statementsCollection at: statementsCollection size - 1) 
					isReturningIf])
				ifTrue: 
					[returnLast _ false.
					statementsCollection allButLast]
				ifFalse: [statementsCollection size = 0
						ifTrue: [Array with: NodeNil]
						ifFalse: [statementsCollection]].
	arguments _ Array new: 0.
	returnLast ifTrue: [self returnLast]! !


!BlockNode methodsFor: 'accessing'!
arguments: argNodes 
	"Decompile."

	arguments _ argNodes! !

!BlockNode methodsFor: 'accessing'!
firstArgument
	^ arguments first! !

!BlockNode methodsFor: 'accessing'!
numberOfArguments

	^arguments size! !

!BlockNode methodsFor: 'accessing'!
returnLast

	self returns
		ifFalse: 
			[returns _ true.
			statements at: statements size put: statements last asReturnNode]! !

!BlockNode methodsFor: 'accessing'!
returnSelfIfNoOther

	self returns
		ifFalse: 
			[statements last == NodeSelf ifFalse: [statements add: NodeSelf].
			self returnLast]! !


!BlockNode methodsFor: 'testing'!
canBeSpecialArgument
	"Can I be an argument of (e.g.) ifTrue:?"

	^arguments size = 0! !

!BlockNode methodsFor: 'testing'!
isComplex

	^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]! !

!BlockNode methodsFor: 'testing'!
isJust: node

	returns ifTrue: [^false].
	^statements size = 1 and: [statements first == node]! !

!BlockNode methodsFor: 'testing'!
isJustCaseError

	^ statements size = 1 and:
		[statements first
			isMessage: #caseError
			receiver: [:r | r==NodeSelf]
			arguments: nil]! !

!BlockNode methodsFor: 'testing'!
isQuick
	^ statements size = 1
		and: [statements first isVariableReference
				or: [statements first isSpecialConstant]]! !

!BlockNode methodsFor: 'testing'!
returns

	^returns or: [statements last isReturningIf]! !


!BlockNode methodsFor: 'code generation'!
code

	^statements first code! !

!BlockNode methodsFor: 'code generation'!
emitExceptLast: stack on: aStream
	| nextToLast |
	nextToLast _ statements size - 1.
	nextToLast < 1 ifTrue: [^ self].  "Only one statement"
	1 to: nextToLast - 1 do:
		[:i | (statements at: i) emitForEffect: stack on: aStream].
	(returns  "Don't pop before a return"
			and: [(statements at: nextToLast) prefersValue])
		ifTrue: [(statements at: nextToLast) emitForValue: stack on: aStream]
		ifFalse: [(statements at: nextToLast) emitForEffect: stack on: aStream]! !

!BlockNode methodsFor: 'code generation'!
emitForEvaluatedEffect: stack on: aStream

	self returns
		ifTrue: 
			[self emitForEvaluatedValue: stack on: aStream.
			stack pop: 1]
		ifFalse: 
			[self emitExceptLast: stack on: aStream.
			statements last emitForEffect: stack on: aStream]! !

!BlockNode methodsFor: 'code generation'!
emitForEvaluatedValue: stack on: aStream
	self emitExceptLast: stack on: aStream.
	statements last emitForValue: stack on: aStream.
	(returns and: [statements size > 1
			and: [(statements at: statements size-1) prefersValue]])
		ifTrue: [stack pop: 1]  "compensate for elided pop prior to return"! !

!BlockNode methodsFor: 'code generation'!
emitForValue: stack on: aStream

	aStream nextPut: LdThisContext.
	stack push: 1.
	nArgsNode emitForValue: stack on: aStream.
	remoteCopyNode
		emit: stack
		args: 1
		on: aStream.
	"Force a two byte jump."
	self emitLong: size code: JmpLong on: aStream.
	stack push: arguments size.
	arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream].
	self emitForEvaluatedValue: stack on: aStream.
	self returns ifFalse: [aStream nextPut: EndRemote].
	stack pop: 1! !

!BlockNode methodsFor: 'code generation'!
sizeExceptLast: encoder
	| codeSize nextToLast |
	nextToLast _ statements size - 1.
	nextToLast < 1 ifTrue: [^ 0]. "Only one statement"
	codeSize _ 0.
	1 to: nextToLast - 1 do: 
		[:i | codeSize _ codeSize + ((statements at: i) sizeForEffect: encoder)].
	^ (returns  "Don't pop before a return"
			and: [(statements at: nextToLast) prefersValue])
		ifTrue: [codeSize + ((statements at: nextToLast) sizeForValue: encoder)]
		ifFalse: [codeSize + ((statements at: nextToLast) sizeForEffect: encoder)]! !

!BlockNode methodsFor: 'code generation'!
sizeForEvaluatedEffect: encoder

	self returns ifTrue: [^self sizeForEvaluatedValue: encoder].
	^(self sizeExceptLast: encoder)
		+ (statements last sizeForEffect: encoder)! !

!BlockNode methodsFor: 'code generation'!
sizeForEvaluatedValue: encoder

	^(self sizeExceptLast: encoder)
		+ (statements last sizeForValue: encoder)! !

!BlockNode methodsFor: 'code generation'!
sizeForValue: encoder
	nArgsNode _ encoder encodeLiteral: arguments size.
	remoteCopyNode _ encoder encodeSelector: #blockCopy:.
	size _ (self sizeForEvaluatedValue: encoder)
				+ (self returns ifTrue: [0] ifFalse: [1]). "endBlock"
	arguments _ arguments collect:  "Chance to prepare debugger remote temps"
				[:arg | arg asStorableNode: encoder].
	arguments do: [:arg | size _ size + (arg sizeForStorePop: encoder)].
	^1 + (nArgsNode sizeForValue: encoder) 
		+ (remoteCopyNode size: encoder args: 1 super: false) + 2 + size! !


!BlockNode methodsFor: 'printing'!
printArgumentsOn: aStream indent: level

	arguments size = 0
		ifFalse: 
			[arguments do: 
				[:arg | 
				aStream nextPut: $:.
				aStream nextPutAll: arg key.
				aStream space].
			aStream nextPutAll: '| '.
			"If >0 args and >1 statement, put all statements on separate lines"
			statements size > 1 ifTrue: [aStream crtab: level]]! !

!BlockNode methodsFor: 'printing'!
printOn: aStream indent: level

	statements size <= 1 ifFalse: [aStream crtab: level].
	aStream nextPut: $[.
	self printArgumentsOn: aStream indent: level.
	self printStatementsOn: aStream indent: level.
	aStream nextPut: $]! !

!BlockNode methodsFor: 'printing'!
printStatementsOn: aStream indent: levelOrZero
	| len shown thisStatement level |
	level _ 1 max: levelOrZero.
	comment == nil
		ifFalse: 
			[self printCommentOn: aStream indent: level.
			aStream crtab: level].
	len _ shown _ statements size.
	(levelOrZero = 0 "top level" and: [statements last isReturnSelf])
		ifTrue: [shown _ 1 max: shown - 1]
		ifFalse: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)])
					ifTrue: [shown _ shown - 1]].
	1 to: shown do: 
		[:i | 
		thisStatement _ statements at: i.
		thisStatement printOn: aStream indent: level.
		i < shown ifTrue: [aStream nextPut: $.; crtab: level].
		thisStatement comment size > 0
			ifTrue: 
				[i = shown ifTrue: [aStream crtab: level].
				thisStatement printCommentOn: aStream indent: level.
				i < shown ifTrue: [aStream crtab: level]]]! !


!BlockNode methodsFor: 'equation translation'!
statements
	^statements! !

!BlockNode methodsFor: 'equation translation'!
statements: val
	statements _ val! !


!BlockNode methodsFor: 'C translation'!
asTranslatorNode
	| statementList newS |
	statementList _ OrderedCollection new.
	statements do: [ :s |
		newS _ s asTranslatorNode.
		newS isStmtList ifTrue: [
			"inline the statement list returned when a CascadeNode is translated"
			statementList addAll: newS statements.
		] ifFalse: [
			statementList add: newS.
		].
	].
	^TStmtListNode new
		setArguments: (arguments asArray collect: [ :arg | arg key ])
		statements: statementList! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BlockNode class
	instanceVariableNames: ''!

!BlockNode class methodsFor: 'instance creation'!
withJust: aNode
	"Used to create a simple block, eg: withJust: NodeNil"
	^ self new statements: (Array with: aNode) returns: false! !
AlignmentMorph subclass: #BookMorph
	instanceVariableNames: 'pageSize pages currentPage copyContents newPagePrototype '
	classVariableNames: 'PageFlipSoundOn '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!BookMorph methodsFor: 'initialization' stamp: 'sw 5/6/1998 10:09'!
addDressing
	| controlColor pageControls |
	self addMorph: (Morph new color: color; extent: 10@10).  "spacer"
	controlColor _ (color saturation > 0.1)
		ifTrue:
			[color lighter]
		ifFalse:
			[color darker].
	pageControls _ Preferences noviceMode
		ifTrue:
			[self makeKidsPageControlsColored: controlColor]
		ifFalse:
			[self makeAuthoringPageControlsColored: controlColor].
	pageControls borderWidth: 1; inset: 4.
			
	self addMorph: pageControls! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 10/3/97 18:49'!
addKidsDressing
	| controlColor pageControls |
	self addMorph: (Morph new color: color; extent: 10@10).  "spacer"
	controlColor _ (color saturation > 0.1)
		ifTrue:
			[color lighter]
		ifFalse:
			[color darker].
	pageControls _ self makeKidsPageControlsColored: controlColor.
	pageControls borderWidth: 1; inset: 4.
			
	self addMorph: pageControls! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 10/18/97 18:03'!
beThoroughlyRepelling
	submorphs do: [:m | m beRepelling].
	self beRepelling! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 8/16/97 13:39'!
closeCurrentPageToDragNDrop
	currentPage ifNotNil: [currentPage openToDragNDrop: false]! !

!BookMorph methodsFor: 'initialization' stamp: 'jm 9/24/97 08:48'!
initialize

	super initialize.
	self setInitialState.
	pages _ OrderedCollection new.
	self addDressing.
	BookMorph turnOffSoundWhile: [self insertPage].
! !

!BookMorph methodsFor: 'initialization' stamp: 'jm 11/17/97 17:26'!
newPages: pageList currentIndex: index
	"Replace all my pages with the given list of BookPageMorphs. Make the current page be the page with the given index."

	pages _ pages species new.
	pages addAll: pageList.
	pages isEmpty ifTrue: [^ self insertPage].
	self goToPage: index.
! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 8/5/97 20:52'!
removeEverything
	currentPage _ nil.
	pages _ OrderedCollection new.
	super removeAllMorphs! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 8/12/97 21:31'!
setInitialState
	orientation _ #vertical.
	centering _ #topLeft.
	hResizing _ #shrinkWrap.
	vResizing _ #shrinkWrap.
	inset _ 5.
	color _ Color white.
	pageSize _ 160@300.
	openToDragNDrop _ true.
	copyContents _ false.! !


!BookMorph methodsFor: 'accessing' stamp: 'tk 12/18/97 09:44'!
allNonSubmorphMorphs
	"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy (put in primarily for bookmorphs)"

	^ pages copyWithout: currentPage! !

!BookMorph methodsFor: 'accessing' stamp: 'sw 11/5/97 13:37'!
currentPage
	^ currentPage! !

!BookMorph methodsFor: 'accessing' stamp: 'sw 9/20/97 20:29'!
pageNamed: aName
	^ pages detect: [:p | p externalName = aName] ifNone: [nil]! !

!BookMorph methodsFor: 'accessing'!
pages

	^ pages
! !

!BookMorph methodsFor: 'accessing' stamp: 'tk 8/13/97 17:01'!
pages: aMorphList

	pages _ aMorphList asOrderedCollection.

	"John:  While it is tempting to put this code here, it is wrong.
	pages size > 0
		ifTrue: [currentPage _ pages first]
		ifFalse: [self insertPage].
	If currentPage is not page 1, then when it comes back in, two pages
are shown at once!!
	Just trust the copying mechanism and let currentPage be copied
correctly. --Ted."! !

!BookMorph methodsFor: 'accessing'!
pageSize: aPoint

	pageSize _ aPoint.
! !


!BookMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:03'!
acceptDroppingMorph: aMorph event: evt
	"Allow the user to add submorphs just by dropping them on this morph."

	(currentPage allMorphs includes: aMorph)
		ifFalse: [currentPage addMorph: aMorph]! !

!BookMorph methodsFor: 'dropping/grabbing'!
allowSubmorphExtraction

	^ false! !

!BookMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:19'!
rootForGrabOf: aMorph

	| root |
	(openToDragNDrop or: [copyContents])
		ifFalse: [^ super rootForGrabOf: aMorph].
	(aMorph = currentPage or: [aMorph owner = self])
		ifTrue: [^ self rootForGrabOf: self].

	root _ aMorph.
	[root = self] whileFalse:
		[root owner == currentPage ifTrue:
			[(copyContents and: [openToDragNDrop not])
				ifTrue: [^ root fullCopy]
				ifFalse: [^ root]].
		root _ root owner].
	^ super rootForGrabOf: aMorph
! !


!BookMorph methodsFor: 'zooming page turns'!
goToPage: pageNumber zoomingFrom: srcButtonMorph

	| bigBalloonMorph i newPage cachedMorph zoomer |
	pages isEmpty ifTrue: [^ self].

	(self isInWorld and:
	 [self world modelOrNil respondsTo: #bigBalloonMorph])
		ifTrue: [bigBalloonMorph _ self world model bigBalloonMorph fullCopy]
		ifFalse: [^ self goToPage: pageNumber].

	bigBalloonMorph position: self world model scaffoldingBook root fullBounds origin.
	bigBalloonMorph removeAllMorphs.
	i _ pageNumber asInteger.
	i > pages size ifTrue: [i _ 1].  "wrap"
	i < 1  ifTrue: [i _ pages size].  "wrap"
	newPage _ pages at: i.
	cachedMorph _ CachingMorph new.
	cachedMorph addMorph: bigBalloonMorph.
	bigBalloonMorph addMorph: newPage fullCopy.
	zoomer _ ZoomMorph new.
	self world addMorphFront: zoomer.
	zoomer zoomFromMorph: srcButtonMorph
							toMorph: cachedMorph
							andThen: [self goToPage: i].
	self world ifNotNil: [self world startSteppingSubmorphsOf: zoomer].
! !

!BookMorph methodsFor: 'zooming page turns'!
nextPageZoomingFrom: aMorph

	| i |
	i _ (pages indexOf: currentPage ifAbsent: [0]) + 1.
	self goToPage: i zoomingFrom: aMorph.
! !

!BookMorph methodsFor: 'zooming page turns'!
previousPageZoomingFrom: aMorph

	| i |
	i _ (pages indexOf: currentPage ifAbsent: [2]) - 1.
	self goToPage: i zoomingFrom: aMorph.
! !

!BookMorph methodsFor: 'zooming page turns' stamp: 'di 1/21/98 07:06'!
showPageTurningFeedbackFromOrigin: oldOrigin ascending: ascending
	ascending ifNotNil:
		[self playPageFlipSound.
		(PageFlipSoundOn and: [oldOrigin ~~ nil]) ifTrue:
			[Display wipeImage: currentPage imageForm
				at: oldOrigin
				delta: (ascending ifTrue: [0@-4] ifFalse: [0@4])]]! !


!BookMorph methodsFor: 'menu' stamp: 'jm 5/15/1998 06:45'!
addBookMenuItemsTo: aCustomMenu hand: aHandMorph
	aCustomMenu
		add: (copyContents
				ifTrue: ['don''t be parts bin when closed']
				ifFalse: ['be parts bin when closed'])
		action: #toggleCopyContents.
	aCustomMenu add: 'previous page' action: #previousPage.
	aCustomMenu add: 'next page' action: #nextPage.
	aCustomMenu add: 'insert a page' action: #insertPage.
	aCustomMenu add: 'delete this page' action: #deletePage.
	aCustomMenu add: 'page controls' action: #pageControls:.
	aCustomMenu add: 'sort pages' action: #sortPages:.
	aCustomMenu add: 'save as new-page prototype' action: #setNewPagePrototype.
	newPagePrototype ifNotNil: [
		aCustomMenu add: 'clear new-page prototype' action: #clearNewPagePrototype].

	(aHandMorph classOfPasteBuffer isKindOf: PasteUpMorph class) ifTrue:
		[aCustomMenu add: 'paste book page'	action: #pasteBookPage]
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 9/13/97 23:24'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self addBookMenuItemsTo: aCustomMenu hand: aHandMorph
	"This factoring allows subclasses, such as TabbedPaletteMorph, to choose different items and different wording and still use the super call for the rest of the metamenu"! !

!BookMorph methodsFor: 'menu' stamp: 'jm 5/14/1998 20:18'!
clearNewPagePrototype
	"Clear the new page prototype."

	newPagePrototype _ nil.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/2/97 15:22'!
configureForKids
	super configureForKids.
	pages do:
		[:aPage | aPage configureForKids].! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/15/97 22:01'!
deleteControls
	"If the receiver has an element answering to the name 'Page Controls', delete it"

	| controls |
	(controls _ self findSubmorphThat: [:m | m externalName = 'Page Controls'] ifAbsent: [nil]) ifNotNil:
		[controls delete.
		self changed]! !

!BookMorph methodsFor: 'menu'!
deletePage

	| oldPage |
	oldPage _ currentPage.
	self nextPage.
	pages remove: oldPage.
	oldPage delete.
	currentPage = oldPage ifTrue: [self nextPage].
	pages isEmpty ifTrue: [self insertPage].
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/4/97 12:05'!
firstPage

	self goToPage: 1.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/9/97 00:02'!
insertPage
	self insertPageColored: self color
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/12/97 21:48'!
insertPage: aPage pageSize: aPageSize
	^ self insertPage: aPage pageSize: aPageSize atIndex: (pages size + 1)! !

!BookMorph methodsFor: 'menu' stamp: 'sw 5/14/1998 11:06'!
insertPage: aPage pageSize: aPageSize atIndex: anIndex

	| sz  predecessor |
	sz _ aPageSize
		ifNil: [currentPage == nil
			ifTrue: [pageSize]
			ifFalse: [currentPage extent]]
		ifNotNil:
			[aPageSize].
	aPage extent: sz.
	((pages isEmpty | anIndex == nil) or: [anIndex > pages size])
		ifTrue:
			[pages add: aPage]
		ifFalse:
			[anIndex <= 1
				ifTrue:
					[pages addFirst: aPage]
				ifFalse:
					[predecessor _ anIndex == nil
						ifTrue:
							[currentPage]
						ifFalse:
							[pages at: anIndex].
					self pages add: aPage after: predecessor]].

	self goToPageMorph: aPage
! !

!BookMorph methodsFor: 'menu' stamp: 'jm 5/14/1998 20:37'!
insertPageColored: aColor

	| sz newPage bw bc |
	currentPage == nil
		ifTrue:
			[sz _ pageSize.
			bw _ 0.
			bc _ Color blue muchLighter]
		ifFalse:
			[sz _ currentPage extent.
			bw _ currentPage borderWidth.
			bc _ currentPage borderColor].
	newPagePrototype
		ifNil: [
			newPage _ PasteUpMorph new extent: sz; color: aColor.
			newPage borderWidth: bw; borderColor: bc]
		ifNotNil: [
			newPage _ newPagePrototype fullCopy].
	newPage resizeToFit: false.
	pages isEmpty
		ifTrue: [pages add: (currentPage _ newPage)]
		ifFalse: [pages add: newPage after: currentPage].
	self nextPage.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/2/97 21:31'!
insertPageShowingString: aString fontName: aName fontSize: aSize
	"For creating text content on a page of a BookMorph, from cold code.  Sadly, can't yet specify font..."
	| aTextMorph tempContents |
	self insertPage.
	aTextMorph _ TextMorph new.
	aTextMorph extent: (self extent - (12@0)).
	aName ifNotNil:
			[aTextMorph string: aString fontName: aName size: aSize]
		ifNil:
			[aTextMorph contentsWrapped: aString].
	tempContents _ aTextMorph contents.
	aTextMorph contentsWrapped: '-'.
	aTextMorph extent: (self extent - (12@0)).
	aTextMorph contentsWrapped: tempContents.

	currentPage addMorph: aTextMorph.! !

!BookMorph methodsFor: 'menu' stamp: 'sw 9/15/97 01:05'!
insertPageShowingString: aString usingFont: aFont 
	"For creating text content on a page of a BookMorph, from cold code.  Sadly, can't yet specify font..."

	self insertPage.
	currentPage addMorph:
		(TextMorph new extent: (self extent - (12@0)); contentsWrapped: aString)! !

!BookMorph methodsFor: 'menu' stamp: 'jm 5/15/1998 06:46'!
invokeBookMenu
	"Answer a menu to be popped up from the book-control panel"
	| aMenu |
	aMenu _ CustomMenu new.
	aMenu addList:	#(
		"	('border color...' 		changeBorderColor:)
			('border width...' 		changeBorderWidth:)
			('lock'					lock)"
			('make bookmark'		bookmarkForThisPage)
			('sort pages'				sortPages:)
			('remove control panel'	deleteControls)
		).
	(self primaryHand classOfPasteBuffer isKindOf: PasteUpMorph class) ifTrue:
		[aMenu add: 'paste book page'	action: #pasteBookPage].

	aMenu add: 'save as new-page prototype' action: #setNewPagePrototype.
	newPagePrototype ifNotNil: [
		aMenu add: 'clear new-page prototype' action: #clearNewPagePrototype].

	aMenu add: (openToDragNDrop ifTrue: ['close'] ifFalse: ['open']) , ' dragNdrop'
			action: #openCloseDragNDrop.

	aMenu invokeOn: self defaultSelection: nil! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/4/97 12:05'!
lastPage
	self goToPage: pages size
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/5/97 21:13'!
newTextMorph
	"Create a new, empty TextMorph that can be placed in this book."

	self isInWorld ifTrue:
		[self primaryHand attachMorph:
			(TextMorph new extent: currentPage width@30)].
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/1/97 00:18'!
nextPage

	| i |
	currentPage == nil ifTrue: [^ self goToPage: 1].
	i _ (pages indexOf: currentPage ifAbsent: [0]) + 1.
	self goToPage: i.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/2/97 21:39'!
pageControls: evt

	| buttonPanel |
	buttonPanel _ self makePageControls.
	buttonPanel borderWidth: 1; inset: 4.
	evt hand attachMorph: buttonPanel.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 5/14/1998 11:04'!
pasteBookPage
	| aPage |
	aPage _ self primaryHand objectToPaste.

	self insertPage: aPage pageSize: aPage extent atIndex: ((pages indexOf: currentPage) - 1).
	"self goToPageMorph: aPage"! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/11/97 23:40'!
previousPage

	| i |
	i _ (pages indexOf: currentPage ifAbsent: [2]) - 1.
	self goToPage: i.
! !

!BookMorph methodsFor: 'menu' stamp: 'jm 5/14/1998 20:17'!
setNewPagePrototype
	"Record the current page as the prototype to be copied when inserting new pages."

	currentPage ifNotNil:
		[newPagePrototype _ currentPage fullCopy].
! !

!BookMorph methodsFor: 'menu' stamp: 'jm 11/17/97 17:33'!
sortPages: evt

	| sorter |
	sorter _ BookPageSorterMorph new forBook: self.
	sorter pageHolder cursor: (pages indexOf: currentPage ifAbsent: [0]).
	evt == nil
		ifTrue: [self world addMorphFront: sorter]
		ifFalse: [evt hand attachMorph: sorter].
! !

!BookMorph methodsFor: 'menu' stamp: 'jm 7/8/97 10:44'!
toggleCopyContents
	"Toggle this morph's ability to behave like a parts bin when closed."

	copyContents _ copyContents not.
! !


!BookMorph methodsFor: 'private' stamp: 'sw 5/13/1998 11:46'!
authorControlSpecs
	^ #(	
			( '<--'		firstPage		'Go to first page')
			( '<-' 		previousPage	'Go to previous page')
			('-'			deletePage		'Delete current page')
			('<<>>'		invokeBookMenu 'Get a menu')
			('+'			insertPage		'Insert new page after this one')
			('->'			nextPage		'Go to next page')
			( '-->'		lastPage			'Go to final page'))! !

!BookMorph methodsFor: 'private' stamp: 'sw 8/12/97 12:16'!
bookmarkForThisPage

	| b |
	b _ SimpleButtonMorph new target: self.
	b actionSelector: #goToPageMorph:.
	b label: 'Bookmark'.
	b arguments: (Array with: currentPage).
	self primaryHand attachMorph: b
! !

!BookMorph methodsFor: 'private' stamp: 'sw 5/13/1998 15:11'!
goToPage: pageNumber

	| pageIndex  oldOrigin aWorld oldRect oldPageNumber ascending |
	pages isEmpty ifTrue: [^ self].

	oldPageNumber _ pages indexOf: currentPage ifAbsent: [1].

	pageIndex _ pageNumber asInteger.
	pageNumber < 1 ifTrue: [pageIndex _ pages size].
	pageNumber > pages size ifTrue: [pageIndex _ 1].


	ascending _ oldPageNumber < pageIndex.
	oldPageNumber = pageIndex ifTrue: [ascending _ nil].

	(aWorld _ self world) ifNotNil:
		[self primaryHand newKeyboardFocus: nil].
	currentPage ifNotNil:
		[(oldRect _ currentPage screenRectangle) ifNotNil:
			[oldOrigin _ oldRect origin].
		currentPage releaseCachedState; delete].
	currentPage _ pages at: pageIndex.
	self addMorphBack: currentPage.
	aWorld ifNotNil:
		[self world startSteppingSubmorphsOf: currentPage.
		self showPageTurningFeedbackFromOrigin: oldOrigin ascending: ascending]! !

!BookMorph methodsFor: 'private' stamp: 'jm 7/1/97 16:43'!
goToPageMorph: aMorph

	| i |
	i _ pages indexOf: aMorph.
	i = 0 ifFalse: [self goToPage: i].
! !

!BookMorph methodsFor: 'private' stamp: 'sw 4/30/1998 12:16'!
goToPageMorphNamed: aName
	| aMorph |
	aMorph _ pages detect: [:p | p externalName = aName] ifNone: [^ self beep].
	self goToPageMorph: aMorph! !

!BookMorph methodsFor: 'private' stamp: 'di 5/6/1998 21:10'!
insertPageLabel: labelString morphs: morphList

	| m c labelAllowance |
	self insertPage.
	labelString ifNotNil:
			[m _ (TextMorph new extent: currentPage width@20; contents: labelString).
		m lock.
		m position: currentPage position + (((currentPage width - m width) // 2) @ 5).
		currentPage addMorph: m.
		labelAllowance _ 40]
		ifNil:
			[labelAllowance _ 0].

	"use a column to align the given morphs, then add them to the page"
	c _ AlignmentMorph newColumn centering: #center.
	c addAllMorphs: morphList.
	c position: currentPage position + (0 @ labelAllowance).
	currentPage addAllMorphs: morphList.
	^ currentPage
! !

!BookMorph methodsFor: 'private' stamp: 'di 5/6/1998 21:10'!
insertPageLabel: labelString morphs: firstColMorphs secondColumnMorphs: secondColMorphs

	| c |
	self insertPageLabel: labelString morphs: firstColMorphs.

	"use a column to align the given morphs, then add them to the page"
	c _ AlignmentMorph newColumn centering: #center.
	c addAllMorphs: secondColMorphs.
	c position: currentPage position + (100@40).
	currentPage addAllMorphs: secondColMorphs.
! !

!BookMorph methodsFor: 'private' stamp: 'sw 10/18/97 18:03'!
kidControlSpecs
	true ifTrue: [^ self minimalKidsControlSpecs].

	^ #(	
			( '<--'		firstPage		'Go to first page')
			( '<-' 		previousPage	'Go to previous page')
			('->'			nextPage		'Go to next page')
			( '-->'		lastPage			'Go to final page'))! !

!BookMorph methodsFor: 'private' stamp: 'sw 10/2/97 18:49'!
makeAuthoringPageControlsColored: aColor
	^ self makePageControlsFrom: self authorControlSpecs color: aColor! !

!BookMorph methodsFor: 'private' stamp: 'sw 10/2/97 18:50'!
makeKidsPageControlsColored: aColor
	^ self makePageControlsFrom: self kidControlSpecs color: aColor! !

!BookMorph methodsFor: 'private' stamp: 'sw 5/21/1998 18:08'!
makeMinimalControlsWithColor: aColor title: aString

	| aButton aColumn aRow but |
	aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor; borderWidth: 0.
	aColumn _ AlignmentMorph newColumn.
	aColumn color: aButton color; borderWidth: 0; inset: 0.
	aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.

	aRow _ AlignmentMorph newRow.
	aRow color: aButton color; borderWidth: 0; inset: 0.
	aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.

	aRow addMorphBack: (but _ aButton fullCopy label: ' < ' ; actionSelector: #previousPage).
	but setBalloonText: 'Go to previous page'.

	aRow addMorphBack: (StringMorph contents: aString) lock.

	aRow addMorphBack: (but _ aButton fullCopy label: ' > ' ; actionSelector: #nextPage).
	but setBalloonText: 'Go to next page'.

	aColumn addMorphBack: aRow.

	aColumn setNameTo: 'Page Controls'.
	
	^ aColumn! !

!BookMorph methodsFor: 'private' stamp: 'di 5/6/1998 21:10'!
makePageControls

	| b c r |
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	c _ AlignmentMorph newColumn.
	c color: b color; borderWidth: 0; inset: 0.
	c hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.

	r _ AlignmentMorph newRow.
	r color: b color; borderWidth: 0; inset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r addMorphBack: (b fullCopy label: '<-';			actionSelector: #previousPage).
	r addMorphBack: (b fullCopy label: 'Insert';		actionSelector: #insertPage).
	r addMorphBack: (b fullCopy label: 'Delete';		actionSelector: #deletePage).
	r addMorphBack: (b fullCopy label: 'Text';		actionSelector: #newTextMorph).
	r addMorphBack: (b fullCopy label: '->';			actionSelector: #nextPage).
	c addMorphBack: r.

	r _ r copy removeAllMorphs.
	r addMorphBack: (b fullCopy label: 'Bookmark';	actionSelector: #bookmarkForThisPage).
	r addMorphBack: (b fullCopy label: 'Save';		actionSelector: #saveBookToFile).
	c addMorphBack: r.
	
	^ c
! !

!BookMorph methodsFor: 'private' stamp: 'sw 5/7/1998 09:06'!
makePageControlsFrom: controlSpecs color: aColor

	| aButton aColumn aRow but |
	aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor.
	aColumn _ AlignmentMorph newColumn.
	aColumn color: aButton color; borderWidth: 0; inset: 0.
	aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.

	aRow _ AlignmentMorph newRow.
	aRow color: aButton color; borderWidth: 0; inset: 0.
	aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	controlSpecs do:
		[:pair | aRow addMorphBack: (but _ aButton fullCopy label: pair first; actionSelector: pair second).
		but setBalloonText: pair third.
		(pair last includesSubString: 'enu')
			ifTrue: [but actWhen: #buttonDown]].
	aColumn addMorphBack: aRow.

	aColumn setNameTo: 'Page Controls'.
	
	^ aColumn! !

!BookMorph methodsFor: 'private' stamp: 'sw 10/18/97 18:03'!
minimalKidsControlSpecs
	^ #(	
			( '<-' 		previousPage	'Go to previous page')
			('->'			nextPage		'Go to next page'))! !

!BookMorph methodsFor: 'private' stamp: 'jm 5/16/1998 10:39'!
playPageFlipSound

	(self world soundsEnabled "user-controllable" and:
		[PageFlipSoundOn])  "mechanism to suppress sounds at init time"
			ifTrue: [self playSoundNamed: 'camera'].
! !

!BookMorph methodsFor: 'private' stamp: 'jm 2/11/98 12:24'!
releaseCachedState
	"Release the cached state of all my pages."

	super releaseCachedState.
	pages do: [:page | page allMorphsDo: [:m | m releaseCachedState]].
! !

!BookMorph methodsFor: 'private' stamp: 'jm 7/1/97 16:55'!
saveBookToFile
	"Save this book in a file."

	| fileName s |
	fileName _ FillInTheBlank request: 'File name for this Book?'.
	fileName isEmpty ifTrue: [^ self].  "abort"

	s _ SmartRefStream newFileNamed: fileName, '.morph'.
	s nextPut: self fullCopy.
	s close.
! !

!BookMorph methodsFor: 'private' stamp: 'sw 8/12/97 12:30'!
switchToAuthorMode
	"Replace the control panel with one specially for authoring"
	
	self deleteControls.
	self addMorph: ((self makeAuthoringPageControlsColored: self color lighter) borderWidth: 1; inset: 4)

! !


!BookMorph methodsFor: 'copying' stamp: 'tk 8/13/97 15:00'!
copyRecordingIn: dict
	"Overridden to copy the pages of this book as well."

	| new |
	new _ super copyRecordingIn: dict.
	new pages: (pages collect: [:pg |
		"the current page was copied with the submorphs"
		(dict includesKey: pg)
			ifTrue: [dict at: pg]  "current page; already copied"
			ifFalse: [pg copyRecordingIn: dict]]).
	^ new
! !

!BookMorph methodsFor: 'copying' stamp: 'jm 7/1/97 17:06'!
updateReferencesUsing: aDictionary

	super updateReferencesUsing: aDictionary.
	pages do: [:page |
		page allMorphsDo: [:m | m updateReferencesUsing: aDictionary]].
! !


!BookMorph methodsFor: 'object fileIn' stamp: 'di 5/21/1998 19:23'!
convertbosfcepbbochvimolppcc0: varDict bosfcepcbbochvimolppccn0: smartRefStrm
	"These variables are automatically stored into the new instance ('pageSize' 'pages' 'currentPage' 'copyContents' ).
	This method is for additional changes. Use statements like (foo _ varDict at: 'foo')."

	"Be sure to to fill in ('newPagePrototype' ) and deal with the information in ()"! !

!BookMorph methodsFor: 'object fileIn' stamp: 'jm 9/24/97 08:49'!
convertbosfcepbbochvimolppccs0: varDict bosfcepbbochvimolppcc0: smartRefStrm
	"These variables are automatically stored into the new instance ('pageSize' 'pages' 'currentPage' 'copyContents' ).
	This method is for additional changes. Use statements like (foo _ varDict at: 'foo')."

	"Be sure to to fill in () and deal with the information in ('saveBlock' )"! !

!BookMorph methodsFor: 'object fileIn' stamp: 'jm 5/15/1998 06:59'!
convertbosfcepcbbochvimolppcc0: varDict bosfcepcbbochvimolppccn0: smartRefStrm
	"Adding newPagePrototype instance variable."
	
	newPagePrototype _ nil.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BookMorph class
	instanceVariableNames: ''!

!BookMorph class methodsFor: 'all' stamp: 'sw 5/13/1998 11:43'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin for authors"
	
	| book |
	book _ self new markAsPartsDonor.
	book removeEverything; pageSize: 128@102; color: (Color r: 0.9 g: 0.9 b: 0.9).
	book borderWidth: 1; borderColor: Color black.
	book addDressing; insertPage.
	^ book! !

!BookMorph class methodsFor: 'all' stamp: 'jm 9/24/97 08:42'!
initialize
	"BookMorph initialize"

	PageFlipSoundOn _ true.
! !

!BookMorph class methodsFor: 'all' stamp: 'jm 9/24/97 08:47'!
turnOffSoundWhile: aBlock
	"Turn off page flip sound during the given block."

	| old |
	old _ PageFlipSoundOn.
	PageFlipSoundOn _ false.
	aBlock value.
	PageFlipSoundOn _ old.
! !
AlignmentMorph subclass: #BookPageSorterMorph
	instanceVariableNames: 'book pageHolder '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:42'!
acceptSort

	| pages |
	pages _ OrderedCollection new.
	pageHolder submorphsDo: [:m |
		(m isKindOf: BookPageThumbnailMorph) ifTrue: [pages add: m page]].
	book newPages: pages currentIndex: pageHolder cursor.
	self delete.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'di 5/6/1998 21:09'!
addControls

	| b r |
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	r _ AlignmentMorph newRow.
	r color: b color; borderWidth: 0; inset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r centering: #topLeft.
	r addMorphBack: (b fullCopy label: 'Okay';	actionSelector: #acceptSort).
	r addMorphBack: (b fullCopy label: 'Cancel';	actionSelector: #cancelSort).
	self addMorphBack: r.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 15:14'!
cancelSort

	self delete.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 19:06'!
forBook: aBookMorph

	book _ aBookMorph.
	pageHolder removeAllMorphs.
	pageHolder addAllMorphs:
		(book pages collect: [:p | BookPageThumbnailMorph new page: p]).
	pageHolder extent: pageHolder width@pageHolder fullBounds height.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 19:40'!
initialize

	super initialize.
	self extent: 440@400;
		orientation: #vertical;
		centering: #topLeft;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		inset: 3;
		color: Color lightGray;
		borderWidth: 2.
	pageHolder _ HolderMorph new extent: self extent - borderWidth.
	pageHolder cursor: 0.
	self addControls.
	self addMorphBack: pageHolder.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 16:46'!
pageHolder

	^ pageHolder
! !
SketchMorph subclass: #BookPageThumbnailMorph
	instanceVariableNames: 'page '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:45'!
computeThumbnail

	| f scale |
	f _ page imageForm.
	scale _ self height / f height.  "keep height invariant"
	self form: (f magnify: f boundingBox by: scale@scale smoothing: 2).
! !

!BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 14:01'!
initialize

	| f |
	super initialize.
	color _ Color lightGray.  "background color"
	f _ Form extent: 60@80 depth: 16.
	f fill: f boundingBox fillColor: color.
	self form: f.
! !

!BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:30'!
page

	^ page
! !

!BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:31'!
page: aBookPageMorph

	page _ aBookPageMorph.
	self computeThumbnail.
! !
Object subclass: #Boolean
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!Boolean commentStamp: 'di 5/22/1998 16:32' prior: 0!
Boolean comment:
'I represent logical values, providing boolean operations and conditional control structures.'!


!Boolean methodsFor: 'logical operations'!
& aBoolean 
	"Evaluating conjunction. Evaluate the argument. Then answer true if 
	both the receiver and the argument are true."

	self subclassResponsibility! !

!Boolean methodsFor: 'logical operations'!
eqv: aBoolean 
	"Answer true if the receiver is equivalent to aBoolean."

	^self == aBoolean! !

!Boolean methodsFor: 'logical operations'!
not
	"Negation. Answer true if the receiver is false, answer false if the 
	receiver is true."

	self subclassResponsibility! !

!Boolean methodsFor: 'logical operations'!
xor: aBoolean 
	"Exclusive OR. Answer true if the receiver is not equivalent to aBoolean."

	^(self == aBoolean) not! !

!Boolean methodsFor: 'logical operations'!
| aBoolean 
	"Evaluating disjunction (OR). Evaluate the argument. Then answer true 
	if either the receiver or the argument is true."

	self subclassResponsibility! !


!Boolean methodsFor: 'controlling'!
and: alternativeBlock 
	"Nonevaluating conjunction. If the receiver is true, answer the value of 
	the argument, alternativeBlock; otherwise answer false without 
	evaluating the argument."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifFalse: alternativeBlock 
	"If the receiver is true (i.e., the condition is true), then the value is the 
	true alternative, which is nil. Otherwise answer the result of evaluating 
	the argument, alternativeBlock. Create an error notification if the 
	receiver is nonBoolean. Execution does not actually reach here because 
	the expression is compiled in-line."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Same as ifTrue:ifFalse:."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifTrue: alternativeBlock 
	"If the receiver is false (i.e., the condition is false), then the value is the 
	false alternative, which is nil. Otherwise answer the result of evaluating 
	the argument, alternativeBlock. Create an error notification if the 
	receiver is nonBoolean. Execution does not actually reach here because 
	the expression is compiled in-line."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock
	"If the receiver is true (i.e., the condition is true), then answer the value 
	of the argument trueAlternativeBlock. If the receiver is false, answer the 
	result of evaluating the argument falseAlternativeBlock. If the receiver 
	is a nonBoolean then create an error notification. Execution does not 
	actually reach here because the expression is compiled in-line."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
or: alternativeBlock 
	"Nonevaluating disjunction. If the receiver is false, answer the value of 
	the argument, alternativeBlock; otherwise answer true without 
	evaluating the argument."

	self subclassResponsibility! !


!Boolean methodsFor: 'copying'!
deepCopy 
	"Receiver has two concrete subclasses, True and False.
	Only one instance of each should be made, so return self."! !

!Boolean methodsFor: 'copying'!
shallowCopy 
	"Receiver has two concrete subclasses, True and False.
	Only one instance of each should be made, so return self."! !


!Boolean methodsFor: 'printing' stamp: 'sw 4/25/1998 12:51'!
basicType
	^ #boolean! !

!Boolean methodsFor: 'printing'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	self printOn: aStream! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Boolean class
	instanceVariableNames: ''!

!Boolean class methodsFor: 'instance creation'!
new
	self error: 'You may not create any more Booleans - this is two-valued logic'! !
ScriptEditorMorph subclass: #BooleanScriptEditor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting-Support'!
!BooleanScriptEditor commentStamp: 'di 5/22/1998 16:32' prior: 0!
BooleanScriptEditor class comment:
'A ScriptEditor required to hold a Boolean'!


!BooleanScriptEditor methodsFor: 'all' stamp: 'sw 10/14/97 12:55'!
storeCodeOn: aStream
	(submorphs size > 0 and: [submorphs first submorphs size > 0]) ifTrue:
		[aStream nextPutAll: '(('.
		super storeCodeOn: aStream.
		aStream nextPutAll: ') ~~ false)'.
		^ self].
	aStream nextPutAll: ' true '! !

!BooleanScriptEditor methodsFor: 'all' stamp: 'di 10/17/97 16:32'!
wantsDroppedMorph: aMorph

	^ aMorph isTileLike and: [aMorph resultType ~~ #command]
! !
Morph subclass: #BorderedMorph
	instanceVariableNames: 'borderWidth borderColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!

!BorderedMorph methodsFor: 'initialization' stamp: 'di 6/20/97 11:07'!
initialize
	super initialize.
	borderColor _ Color black.
	borderWidth _ 2.
! !


!BorderedMorph methodsFor: 'accessing' stamp: 'sw 8/6/97 14:34'!
borderColor
	^ borderColor! !

!BorderedMorph methodsFor: 'accessing' stamp: 'jm 5/14/1998 11:07'!
borderColor: colorOrSymbolOrNil

	borderColor = colorOrSymbolOrNil ifFalse: [
		borderColor _ colorOrSymbolOrNil.
		self changed].
! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:24'!
borderInset
	self borderColor: #inset! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:25'!
borderRaised
	self borderColor: #raised! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:09'!
borderWidth
	^ borderWidth! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/17/97 14:57'!
borderWidth: anInteger
	borderColor ifNil: [borderColor _ Color black].
	borderWidth _ anInteger max: 0.
	self changed! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:19'!
doesBevels
	"To return true means that this object can show bevelled borders, and
	therefore can accept, eg, #raised or #inset as valid borderColors.
	Must be overridden by subclasses that do not support bevelled borders."

	^ true! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 4/13/98 15:22'!
wearCostume: anotherMorph
	"Modify the receiver so that it resembles anotherMorph"

	super wearCostume: anotherMorph.
	self setBorderWidth: anotherMorph borderWidth borderColor: anotherMorph borderColor
! !


!BorderedMorph methodsFor: 'drawing' stamp: 'di 1/9/98 22:25'!
drawOn: aCanvas 
	"Draw a rectangle with a solid, inset, or raised border.
	Note: the raised border color is generated from the receiver's own color,
	while the inset border color is generated from the color of its owner.
	This behavior is visually more consistent. Thanks to Hans-Martin Mosner."

	| insetColor |
	borderWidth = 0 ifTrue: [  "no border"
		aCanvas fillRectangle: bounds color: color.
		^ self].

	borderColor == #raised ifTrue: [
		^ aCanvas frameAndFillRectangle: bounds
			fillColor: color
			borderWidth: borderWidth
			topLeftColor: color lighter
			bottomRightColor: color darker].

	borderColor == #inset ifTrue: [
		insetColor _ owner colorForInsets.
		^ aCanvas frameAndFillRectangle: bounds
			fillColor: color
			borderWidth: borderWidth
			topLeftColor: insetColor darker
			bottomRightColor: insetColor lighter].

	"solid color border"
	aCanvas frameAndFillRectangle: bounds
		fillColor: color
		borderWidth: borderWidth
		borderColor: borderColor.! !

!BorderedMorph methodsFor: 'drawing' stamp: 'di 5/17/1998 00:16'!
drawOnFills: aRectangle
	^ (bounds containsRect: aRectangle) and: [self isOpaque]! !

!BorderedMorph methodsFor: 'drawing' stamp: 'di 5/22/1998 08:45'!
isOpaque
	color isTransparent ifTrue: [^ false].
	borderWidth = 0
		ifTrue: [^ true]
		ifFalse: [^ borderColor isColor not or: [borderColor isTransparent not]]! !


!BorderedMorph methodsFor: 'geometry' stamp: 'di 6/20/97 11:15'!
innerBounds
	^ bounds insetBy: borderWidth! !


!BorderedMorph methodsFor: 'menu' stamp: 'sw 8/5/97 13:33'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addList: #(('border color...' changeBorderColor:)
						('border width...' changeBorderWidth:)).
	self doesBevels ifTrue:
		[borderColor == #raised ifFalse: [aCustomMenu add: 'raised bevel' action: #borderRaised].
		borderColor == #inset ifFalse: [aCustomMenu add: 'inset bevel' action: #borderInset]]
! !

!BorderedMorph methodsFor: 'menu' stamp: 'sw 5/13/1998 12:08'!
changeBorderColor: evt
	| aHand |
	aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand].
	aHand changeColorTarget: self selector: #borderColor:.
! !

!BorderedMorph methodsFor: 'menu' stamp: 'sw 5/13/1998 12:11'!
changeBorderWidth: evt
	| handle origin aHand |
	aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
	origin _ aHand gridPointRaw.
	handle _ HandleMorph new forEachPointDo:
		[:newPoint | handle removeAllMorphs.
		handle addMorph:
			(PolygonMorph vertices: (Array with: origin with: newPoint)
				color: Color black borderWidth: 1 borderColor: Color black).
		self borderWidth: (newPoint - origin) r asInteger // 5].
	aHand attachMorph: handle.
	handle startStepping! !

!BorderedMorph methodsFor: 'menu' stamp: 'sw 5/21/1998 15:21'!
slotNamesAndTypesForBank: aNumber
	"Return an array of part names and part types for use in a viewer on the receiver's costumee; here we only put the costume-specific parts"
	^ aNumber == 2
		ifTrue: 
			[#(
			(color			color		readWrite	getColor				setColor:)
			(borderWidth 		number		readWrite	getBorderWidth	setBorderWidth:)
			(borderColor			color		readWrite	getBorderColor	setBorderColor:)
		"(mouseX			number		readOnly	getMouseX			unused)"
		"(mouseY		number		readOnly	getMouseY			unused)"
)]

		ifFalse:
			[super slotNamesAndTypesForBank: aNumber]
! !


!BorderedMorph methodsFor: 'printing' stamp: 'di 6/20/97 11:20'!
fullPrintOn: aStream
	aStream nextPutAll: '('.
	super fullPrintOn: aStream.
	aStream nextPutAll: ') setBorderWidth: '; print: borderWidth;
		nextPutAll: ' borderColor: ' , (self colorString: borderColor)! !


!BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:21'!
setBorderWidth: w borderColor: bc
	self borderWidth: w.
	self borderColor: bc.! !

!BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:22'!
setColor: c borderWidth: w borderColor: bc
	self color: c.
	self borderWidth: w.
	self borderColor: bc.! !
Morph subclass: #BouncingAtomsMorph
	instanceVariableNames: 'damageReported infectionHistory transmitInfection '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!BouncingAtomsMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
BouncingAtomsMorph comment:
'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.
'!


!BouncingAtomsMorph methodsFor: 'all'!
addAtoms: n
	"Add a bunch of new atoms."

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

!BouncingAtomsMorph methodsFor: 'all'!
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].! !

!BouncingAtomsMorph methodsFor: 'all'!
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 |
	count _ submorphs size.
	sortedAtoms _ submorphs asSortedCollection:
		[ :m1 :m2 | m1 position x < m2 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.
			(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)].
				continue _ (j _ j + 1) <= count.
			] ifFalse: [
				continue _ false.
			].
		].
	].
	^ collisions! !

!BouncingAtomsMorph methodsFor: 'all'!
drawOn: aCanvas
	"Clear the damageReported flag when redrawn."

	super drawOn: aCanvas.
	damageReported _ false.! !

!BouncingAtomsMorph methodsFor: 'all' stamp: 'jm 7/30/97 09:45'!
initialize

	super initialize.
	damageReported _ false.
	self extent: 400@250.
	self color: (Color r: 0.8 g: 1.0 b: 0.8).
	infectionHistory _ OrderedCollection new.
	transmitInfection _ false.
 	self addAtoms: 30.
! !

!BouncingAtomsMorph methodsFor: 'all'!
invalidRect: damageRect
	"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].  "just report once"
		damageReported _ true.
	] ifFalse: [super invalidRect: damageRect].  "ordinary damage report"! !

!BouncingAtomsMorph methodsFor: 'all'!
setGermCount

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

!BouncingAtomsMorph methodsFor: 'all'!
startInfection

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

!BouncingAtomsMorph methodsFor: 'all'!
step
	"Bounce those atoms!!"

	| r |
	r _ bounds origin corner: (bounds corner - (8@8)).
	self submorphsDo: [ :m |
		(m isMemberOf: AtomMorph) ifTrue: [m bounceIn: r]].
	transmitInfection ifTrue: [self transmitInfection].
! !

!BouncingAtomsMorph methodsFor: 'all'!
stepTime
	"As fast as possible."

	^ 0! !

!BouncingAtomsMorph methodsFor: 'all'!
transmitInfection

	| infected count graph |
	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: [
		"done!! place a graph of the infection history in the world"
		graph _ GraphMorph new data: infectionHistory.
		graph position: bounds topRight + (10@0).
		graph extent: (((infectionHistory size * 3) + (2 * graph borderWidth))@count).
		self world addMorph: graph.
		graph changed.
		transmitInfection _ false.
		self stopStepping].
! !
Object subclass: #BraceConstructor
	instanceVariableNames: 'elements initIndex subBraceSize constructor decompiler '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!

!BraceConstructor methodsFor: 'constructing'!
codeBrace: numElements fromBytes: aDecompiler withConstructor: aConstructor
	"Decompile.  Consume at least a Pop and usually several stores into variables
	 or braces.  See BraceNode<formBrace for details."

	decompiler _ aDecompiler.
	constructor _ aConstructor.
	elements _ Array new: (initIndex _ numElements).
	[decompiler interpretNextInstructionFor: self.
	 initIndex = 0]
		whileFalse: [].
	^constructor codeBrace: elements! !


!BraceConstructor methodsFor: 'instruction decoding'!
doPop
	"Decompile."! !

!BraceConstructor methodsFor: 'instruction decoding'!
popIntoLiteralVariable: association
	"Decompile."

	elements at: initIndex put: (constructor codeAnyLitInd: association).
	initIndex _ initIndex - 1! !

!BraceConstructor methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset
	"Decompile."

	elements at: initIndex put: (constructor codeInst: offset).
	initIndex _ initIndex - 1! !

!BraceConstructor methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset
	"Decompile."

	elements at: initIndex put: (decompiler tempAt: offset).
	initIndex _ initIndex - 1! !

!BraceConstructor methodsFor: 'instruction decoding'!
pushConstant: value

	subBraceSize _ value! !

!BraceConstructor methodsFor: 'instruction decoding'!
send: selector super: superFlag numArgs: numArgs

	selector == #toBraceStack:
		ifFalse: [self error: 'Malformed brace-variable code'].
	elements at: initIndex put:
		(BraceConstructor new
			codeBrace: subBraceSize
			fromBytes: decompiler
			withConstructor: constructor).
	initIndex _ initIndex - 1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BraceConstructor class
	instanceVariableNames: ''!

!BraceConstructor class methodsFor: 'examples'!
example
	"Test the {a. b. c} syntax.  For more examples, see SequenceableCollection-casing
	 and Dictionary-casing."

	| a b c d e x y |
	x _ {1. {2. 3}. 4}.
	{a. {b. c}. d. e} _ x, {5}, {}.
	y _ {a} _ {0}.
	{} _ {}.
	^{e. d. c. b. a + 1. y first} as: Set

"BraceNode example"
"Smalltalk garbageCollect.
 Time millisecondsToRun: [20 timesRepeat: [BraceNode example]] 1097 2452"! !
ParseNode subclass: #BraceNode
	instanceVariableNames: 'elements sourceLocations collClassNode nElementsNode fromBraceStackNode toBraceStackNode withNode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!

!BraceNode methodsFor: 'initialize-release'!
collClass: aParseNode

	collClassNode _ aParseNode! !

!BraceNode methodsFor: 'initialize-release'!
elements: collection
	"Decompile."

	elements _ collection! !

!BraceNode methodsFor: 'initialize-release'!
elements: collection sourceLocations: locations
	"Compile."

	elements _ collection.
	sourceLocations _ locations! !


!BraceNode methodsFor: 'testing'!
assignmentCheck: encoder at: location

	| loc |
	elements do:
		[:element |
		(loc _ element assignmentCheck: encoder at: location) >= 0 ifTrue: [^loc]].
	^-1! !

!BraceNode methodsFor: 'testing'!
blockAssociationCheck: encoder
	"If all elements are MessageNodes of the form [block]->[block], and there is at
	 least one element, answer true.
	 Otherwise, notify encoder of an error."

	elements size = 0
		ifTrue: [^encoder notify: 'At least one case required'].
	elements with: sourceLocations do:
			[:x :loc |
			(x 	isMessage: #->
				receiver:
					[:rcvr |
					(rcvr isKindOf: BlockNode) and: [rcvr numberOfArguments = 0]]
				arguments:
					[:arg |
					(arg isKindOf: BlockNode) and: [arg numberOfArguments = 0]])
			  ifFalse:
				[^encoder notify: 'Association between 0-argument blocks required' at: loc]].
	^true! !

!BraceNode methodsFor: 'testing'!
numElements

	^ elements size! !


!BraceNode methodsFor: 'code generation'!
emitForValue: stack on: aStream
	"elem1, ..., elemN, collectionClass, N, fromBraceStack:"

	elements do: [:element | element emitForValue: stack on: aStream].
	collClassNode emitForValue: stack on: aStream.
	nElementsNode emitForValue: stack on: aStream.
	fromBraceStackNode emit: stack args: 1 on: aStream.
	stack pop: elements size! !

!BraceNode methodsFor: 'code generation'!
emitStore: stack on: aStream

	aStream nextPut: Dup. stack push: 1.
	self emitStorePop: stack on: aStream! !

!BraceNode methodsFor: 'code generation'!
emitStorePop: stack on: aStream
	"N, toBraceStack:, pop, pop elemN, ..., pop elem1"

	nElementsNode emitForValue: stack on: aStream.
	toBraceStackNode emit: stack args: 1 on: aStream.
	stack push: elements size.
	aStream nextPut: Pop. stack pop: 1.
	elements reverseDo: [:element | element emitStorePop: stack on: aStream]! !

!BraceNode methodsFor: 'code generation'!
sizeForStore: encoder

	^1 + (self sizeForStorePop: encoder)! !

!BraceNode methodsFor: 'code generation'!
sizeForStorePop: encoder
	"N, toBraceStack:, pop, pop elemN, ..., pop elem1"

	nElementsNode _ encoder encodeLiteral: elements size.
	toBraceStackNode _ encoder encodeSelector: #toBraceStack:.
	^elements inject:
		(nElementsNode sizeForValue: encoder) +
		(toBraceStackNode size: encoder args: 1 super: false) + 1 into:
			[:subTotal :element |
		 	subTotal + (element sizeForStorePop: encoder)]! !

!BraceNode methodsFor: 'code generation'!
sizeForValue: encoder
	"elem1, ..., elemN, collectionClass, N, fromBraceStack:"

	nElementsNode _ encoder encodeLiteral: elements size.
	collClassNode isNil ifTrue:
		[collClassNode _ encoder encodeVariable: #Array].
	fromBraceStackNode _ encoder encodeSelector: #fromBraceStack:.
	^elements inject:
		(nElementsNode sizeForValue: encoder) +
		(collClassNode sizeForValue: encoder) +
		(fromBraceStackNode size: encoder args: 1 super: false)
	 into:
		[:subTotal :element |
		 subTotal + (element sizeForValue: encoder)]! !


!BraceNode methodsFor: 'enumerating'!
casesForwardDo: aBlock
	"For each case in forward order, evaluate aBlock with three arguments:
	 the key block, the value block, and whether it is the last case."

	| numCases case |
	1 to: (numCases _ elements size) do:
		[:i |
		case _ elements at: i.
		aBlock value: case receiver value: case arguments first value: i=numCases]! !

!BraceNode methodsFor: 'enumerating'!
casesReverseDo: aBlock
	"For each case in reverse order, evaluate aBlock with three arguments:
	 the key block, the value block, and whether it is the last case."

	| numCases case |
	(numCases _ elements size) to: 1 by: -1 do:
		[:i |
		case _ elements at: i.
		aBlock value: case receiver value: case arguments first value: i=numCases]! !

!BraceNode methodsFor: 'enumerating'!
do: aBlock
	"For each element in order, evaluate aBlock with two arguments: the element,
	 and whether it is the last element."

	| numElements |
	1 to: (numElements _ elements size) do:
		[:i | aBlock value: (elements at: i) value: i=numElements]! !

!BraceNode methodsFor: 'enumerating'!
reverseDo: aBlock
	"For each element in reverse order, evaluate aBlock with two arguments: the element,
	 and whether it is the last element."

	| numElements |
	(numElements _ elements size) to: 1 by: -1 do:
		[:i | aBlock value: (elements at: i) value: i=numElements]! !


!BraceNode methodsFor: 'printing'!
printOn: aStream indent: level

	| shown |
	aStream nextPut: ${.
	shown _ elements size.
	1 to: shown do: 
		[:i | 
		(elements at: i) printOn: aStream indent: level.
		i < shown ifTrue: [aStream nextPut: $.; space]].
	aStream nextPut: $}! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BraceNode class
	instanceVariableNames: ''!

!BraceNode class methodsFor: 'examples'!
example
	"Test the {a. b. c} syntax."

	| a b c d e x y |
	x _ {1. {2. 3}. 4}.
	{a. {b. c}. d. e} _ x, {5}, {}.
	y _ {a} _ {0}.
	{} _ {}.
	^{e. d. c. b. a + 1. y first} as: Set

"BraceNode example"
"Smalltalk garbageCollect.
 Time millisecondsToRun: [20 timesRepeat: [BraceNode example]] 1097 2452"! !
StringHolder subclass: #Browser
	instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer systemCategoryListIndex classListIndex messageCategoryListIndex messageListIndex editSelection metaClassIndicated '
	classVariableNames: 'RecentClasses '
	poolDictionaries: ''
	category: 'Interface-Browser'!
!Browser commentStamp: 'di 5/22/1998 16:32' prior: 0!
Browser comment:
'I represent a query path into the class descriptions, the software of the system.'!


!Browser methodsFor: 'initialize-release'!
browserWindowActivated
	"Called when a window whose model is the receiver is reactivated, giving the receiver an opportunity to take steps if it wishes.  The default is to do nothing.  8/5/96 sw"! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 15:22'!
buildClassSwitchView

	| aSwitchView |
	aSwitchView _ PluggableButtonView
		on: self
		getState: #classMessagesIndicated
		action: #indicateClassMessages.
	aSwitchView
		label: 'class';
		window: (0@0 extent: 15@8);
		askBeforeChanging: true.
	^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:10'!
buildCommentSwitchView

	| aSwitchView |
	aSwitchView _ PluggableButtonView
		on: self
		getState: #classCommentIndicated
		action: #editComment.
	aSwitchView
		label: '?' asText allBold asParagraph;
		borderWidthLeft: 0 right: 1 top: 0 bottom: 0;	
		window: (0@0 extent: 10@8);
		askBeforeChanging: true.
	^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:11'!
buildInstanceClassSwitchView
	| aView aSwitchView instSwitchView comSwitchView |

	aView _ View new model: self.
	aView window: (0 @ 0 extent: 50 @ 8).
	instSwitchView _ self buildInstanceSwitchView.
	aView addSubView: instSwitchView.
	comSwitchView _ self buildCommentSwitchView.
	aView addSubView: comSwitchView toRightOf: instSwitchView.
	aSwitchView _ self buildClassSwitchView.
	aView addSubView: aSwitchView toRightOf: comSwitchView.
	^aView! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:10'!
buildInstanceSwitchView

	| aSwitchView |
	aSwitchView _ PluggableButtonView
		on: self
		getState: #instanceMessagesIndicated
		action: #indicateInstanceMessages.
	aSwitchView
		label: 'instance';
		borderWidthLeft: 0 right: 1 top: 0 bottom: 0;	
		window: (0@0 extent: 25@8);
		askBeforeChanging: true.
	^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 15:04'!
buildMorphicSwitches

	| instanceSwitch commentSwitch classSwitch row |
	instanceSwitch _ PluggableButtonMorph
		on: self
		getState: #instanceMessagesIndicated
		action: #indicateInstanceMessages.
	instanceSwitch
		label: 'instance';
		askBeforeChanging: true.
	commentSwitch _ PluggableButtonMorph
		on: self
		getState: #classCommentIndicated
		action: #editComment.
	commentSwitch
		label: '?' asText allBold asParagraph;
		askBeforeChanging: true.
	classSwitch _ PluggableButtonMorph
		on: self
		getState: #classMessagesIndicated
		action: #indicateClassMessages.
	classSwitch
		label: 'class';
		askBeforeChanging: true.
	row _ AlignmentMorph newRow
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		inset: 0;
		borderColor: Color transparent;
		addMorphBack: instanceSwitch;
		addMorphBack: commentSwitch;
		addMorphBack: classSwitch.
	^ row
! !

!Browser methodsFor: 'initialize-release'!
defaultBackgroundColor
	^ #lightGreen! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 17:21'!
openAsMorphClassEditing: editString
	"Create a pluggable version a Browser on just a single class."
	| window codePane |
	window _ (SystemWindow labelled: 'later') model: self.

	window addMorph: (PluggableListMorph on: self list: #classListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #classListMenu:)
		frame: (0@0 extent: 0.5@0.06).
	window addMorph: self buildMorphicSwitches
		frame: (0.5@0 extent: 0.5@0.06).
	window addMorph: (PluggableListMorph on: self list: #messageCategoryList
			selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
			menu: #messageCategoryMenu:)
		frame: (0@0.06 extent: 0.5@0.30).
	window addMorph: (PluggableListMorph on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:shifted:)
		frame: (0.5@0.06 extent: 0.5@0.30).

	codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	editString ifNotNil: [codePane editString: editString.
					codePane hasUnacceptedEdits: true].
	window addMorph: codePane
		frame: (0@0.36 corner: 1@1).

	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 16:08'!
openAsMorphEditing: editString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| window codePane |
	window _ (SystemWindow labelled: 'later') model: self.

	window addMorph: (PluggableListMorph on: self list: #systemCategoryList
			selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex:
			menu: #systemCategoryMenu:)
		frame: (0@0 extent: 0.25@0.4).
	window addMorph: (PluggableListMorph on: self list: #classList
			selected: #classListIndex changeSelected: #classListIndex:
			menu: #classListMenu:)
		frame: (0.25@0 extent: 0.25@0.3).
	window addMorph: self buildMorphicSwitches
		frame: (0.25@0.3 extent: 0.25@0.1).
	window addMorph: (PluggableListMorph on: self list: #messageCategoryList
			selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
			menu: #messageCategoryMenu:)
		frame: (0.5@0 extent: 0.25@0.4).
	window addMorph: (PluggableListMorph on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:shifted:)
		frame: (0.75@0 extent: 0.25@0.4).

	codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	editString ifNotNil: [codePane editString: editString.
					codePane hasUnacceptedEdits: true].
	window addMorph: codePane
		frame: (0@0.4 corner: 1@1).

	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/6/1998 21:36'!
openAsMorphMessageEditing: editString
	"Create a pluggable version a Browser on just a messageCategory."
	| window codePane |
	window _ (SystemWindow labelled: 'later') model: self.

	window addMorph: (PluggableListMorph on: self list: #messageListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #messageListMenu:shifted:)
		frame: (0@0 extent: 1.0@0.06).

	codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	editString ifNotNil: [codePane editString: editString.
					codePane hasUnacceptedEdits: true].
	window addMorph: codePane
		frame: (0@0.06 corner: 1@1).

	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/6/1998 21:36'!
openAsMorphMsgCatEditing: editString
	"Create a pluggable version a Browser on just a messageCategory."
	| window codePane |
	window _ (SystemWindow labelled: 'later') model: self.

	window addMorph: (PluggableListMorph on: self list: #messageCatListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #messageCategoryMenu:)
		frame: (0@0 extent: 1.0@0.06).
	window addMorph: (PluggableListMorph on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:shifted:)
		frame: (0@0.06 extent: 1.0@0.30).

	codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	editString ifNotNil: [codePane editString: editString.
					codePane hasUnacceptedEdits: true].
	window addMorph: codePane
		frame: (0@0.36 corner: 1@1).

	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 17:19'!
openAsMorphSysCatEditing: editString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| window codePane |
	window _ (SystemWindow labelled: 'later') model: self.

	window addMorph: (PluggableListMorph on: self list: #systemCategorySingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #systemCategoryMenu:)
		frame: (0@0 extent: 1.0@0.06).
	window addMorph: (PluggableListMorph on: self list: #classList
			selected: #classListIndex changeSelected: #classListIndex:
			menu: #classListMenu:)
		frame: (0@0.06 extent: 0.3333@0.24).
	window addMorph: self buildMorphicSwitches
		frame: (0@0.3 extent: 0.3333@0.06).
	window addMorph: (PluggableListMorph on: self list: #messageCategoryList
			selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
			menu: #messageCategoryMenu:)
		frame: (0.3333@0.06 extent: 0.3333@0.30).
	window addMorph: (PluggableListMorph on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:shifted:)
		frame: (0.6666@0.06 extent: 0.3333@0.30).

	codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	editString ifNotNil: [codePane editString: editString.
					codePane hasUnacceptedEdits: true].
	window addMorph: codePane
		frame: (0@0.36 corner: 1@1).

	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 17:07'!
openEditString: aString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| systemCategoryListView classListView 
	messageCategoryListView messageListView browserCodeView topView switchView |

	World ifNotNil: [^ self openAsMorphEditing: aString].
	Sensor leftShiftDown ifTrue: [^ self openAsMorphEditing: aString "testing"].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	systemCategoryListView _ PluggableListView on: self
		list: #systemCategoryList
		selected: #systemCategoryListIndex
		changeSelected: #systemCategoryListIndex:
		menu: #systemCategoryMenu:.
	systemCategoryListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: systemCategoryListView.

	classListView _ PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: #classListMenu:.
	classListView window: (0 @ 0 extent: 50 @ 62).
	topView addSubView: classListView toRightOf: systemCategoryListView.

	switchView _ self buildInstanceClassSwitchView.
	switchView borderWidth: 1.
	topView addSubView: switchView below: classListView.

	messageCategoryListView _ PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageCategoryListView toRightOf: classListView.

	messageListView _ PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	browserCodeView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@110).
	topView addSubView: browserCodeView below: systemCategoryListView.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 5/6/1998 21:25'!
openMessageCatEditString: aString
	"Create a pluggable version of the views for a Browser that just shows one message category."
	| messageCategoryListView messageListView browserCodeView topView |

	World ifNotNil: [^ self openAsMorphMsgCatEditing: aString].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	messageCategoryListView _ PluggableListView on: self
		list: #messageCatListSingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 200 @ 12).
	topView addSubView: messageCategoryListView.

	messageListView _ PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView window: (0 @ 0 extent: 200 @ 70).
	topView addSubView: messageListView below: messageCategoryListView.

	browserCodeView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@(200-12-70)).
	topView addSubView: browserCodeView below: messageListView.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 5/6/1998 21:27'!
openMessageEditString: aString
	"Create a pluggable version of the views for a Browser that just shows one message."
	| messageListView browserCodeView topView |

	World ifNotNil: [^ self openAsMorphMessageEditing: aString].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	messageListView _ PluggableListView on: self
		list: #messageListSingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #messageListMenu:shifted:.
	messageListView window: (0 @ 0 extent: 200 @ 12).
	topView addSubView: messageListView.

	browserCodeView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@(200-12)).
	topView addSubView: browserCodeView below: messageListView.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 5/6/1998 21:25'!
openOnClassWithEditString: aString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| classListView messageCategoryListView messageListView browserCodeView topView switchView |

	World ifNotNil: [^ self openAsMorphClassEditing: aString].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	classListView _ PluggableListView on: self
		list: #classListSingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #classListMenu:.
	classListView window: (0 @ 0 extent: 100 @ 12).
	topView addSubView: classListView.

	messageCategoryListView _ PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 100 @ 70).
	topView addSubView: messageCategoryListView below: classListView.

	messageListView _ PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView window: (0 @ 0 extent: 100 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	switchView _ self buildInstanceClassSwitchView.
	switchView borderWidth: 1.
	switchView 
		window: switchView window 
		viewport: (classListView viewport topRight 
					corner: messageListView viewport topRight).
	topView addSubView: switchView toRightOf: classListView.

	browserCodeView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@(200-12-70)).
	topView addSubView: browserCodeView below: messageCategoryListView.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/8/1998 22:31'!
openSystemCatEditString: aString
	"Create a pluggable version of all the views for a Browser, including views and controllers.  The top list view is of the currently selected system class category--a single item list."
	| systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView |

	World ifNotNil: [^ self openAsMorphSysCatEditing: aString].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	systemCategoryListView _ PluggableListView on: self
		list: #systemCategorySingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #systemCategoryMenu:.
	systemCategoryListView window: (0 @ 0 extent: 200 @ 12).
	topView addSubView: systemCategoryListView.

	classListView _ PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: #classListMenu:.
	classListView window: (0 @ 0 extent: 67 @ 62).
	topView addSubView: classListView below: systemCategoryListView.

	messageCategoryListView _ PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 66 @ 70).
	topView addSubView: messageCategoryListView toRightOf: classListView.

	switchView _ self buildInstanceClassSwitchView.
	switchView 
		window: switchView window 
		viewport: (classListView viewport bottomLeft 
					corner: messageCategoryListView viewport bottomLeft).
	switchView borderWidth: 1.
	topView addSubView: switchView below: classListView.

	messageListView _ PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView window: (0 @ 0 extent: 67 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	browserCodeView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@(110-12)).
	topView addSubView: browserCodeView below: switchView.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 5/2/1998 14:35'!
setClass: aBehavior selector: aSymbol
	"Set the state of a new, uninitialized Browser."

	| isMeta aClass systemCatIndex messageCatIndex |
	aBehavior ifNil: [^ self].
	(aBehavior isKindOf: Metaclass)
		ifTrue: [isMeta _ true. aClass _ aBehavior soleInstance]
		ifFalse: [isMeta _ false. aClass _ aBehavior].
	systemCatIndex _ SystemOrganization categories indexOf: aClass category.
	self systemCategoryListIndex: systemCatIndex.
	self classListIndex:
			((SystemOrganization listAtCategoryNumber: systemCatIndex)
					indexOf: aClass name).
	self metaClassIndicated: isMeta.
	aSymbol ifNil: [^ self].
	messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol.
	self messageCategoryListIndex: messageCatIndex.
	messageCatIndex = 0 ifTrue: [^ self].
	self messageListIndex:
			((aBehavior organization listAtCategoryNumber: messageCatIndex)
					indexOf: aSymbol).
! !

!Browser methodsFor: 'initialize-release'!
systemOrganizer: aSystemOrganizer 
	"Initialize the receiver as a perspective on the system organizer, 
	aSystemOrganizer. Typically there is only one--the system variable 
	SystemOrganization."

	super initialize.
	contents _ nil.
	systemOrganizer _ aSystemOrganizer.
	systemCategoryListIndex _ 0.
	classListIndex _ 0.
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	metaClassIndicated _ false.
	self setClassOrganizer.
	editSelection _ #none! !


!Browser methodsFor: 'accessing' stamp: 'tk 4/9/98 13:47'!
contents
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information. This information is the
	method of the currently selected class and message."
	| comment theClass |
	editSelection == #none ifTrue: [^ ''].
	editSelection == #editSystemCategories 
		ifTrue: [^ systemOrganizer printString].
	editSelection == #newClass 
		ifTrue: [^ Class template: self selectedSystemCategoryName].
	editSelection == #editClass 
		ifTrue: [^ self selectedClassOrMetaClass definition].
	editSelection == #editComment 
		ifTrue: [(theClass _ self selectedClass) ifNil: [^ ''].
				comment _ theClass comment.
				comment size = 0
				ifTrue: [ ^ 'This class has not yet been commented.']
				ifFalse: [ ^ comment]].
	editSelection == #hierarchy 
		ifTrue: [^ self selectedClassOrMetaClass printHierarchy].
	editSelection == #editMessageCategories 
		ifTrue: [^ self classOrMetaClassOrganizer printString].
	editSelection == #newMessage
		ifTrue: [^ self selectedClassOrMetaClass sourceCodeTemplate].
	editSelection == #editMessage
		ifTrue: [^ self selectedMessage].
	editSelection == #byteCodes ifTrue: [
		^ (self selectedClassOrMetaClass compiledMethodAt: 
				self selectedMessageName) symbolic asText].

	self error: 'Browser internal error: unknown edit selection.'! !

!Browser methodsFor: 'accessing' stamp: 'di 1/14/98 14:01'!
contents: input notifying: aController 
	"The retrieved information has changed and its source must now be 
	updated. The information can be a variety of things, depending on the 
	list selections (such as templates for class or message definition, methods) 
	or the user menu commands (such as definition, comment, hierarchy). 
	Answer the result of updating the source."
	| aString aText theClass |
	aString _ input asString.
	aText _ input asText.

	editSelection == #editSystemCategories 
		ifTrue: [^ self changeSystemCategories: aString].
	editSelection == #editClass | (editSelection == #newClass) 
		ifTrue: [^ self defineClass: aString notifying: aController].
	editSelection == #editComment 
		ifTrue: [theClass _ self selectedClass.
				theClass ifNil: [PopUpMenu notify: 'You must select a class
before giving it a comment.'.
				^ false].
				theClass comment: aText. ^ true].
	editSelection == #hierarchy ifTrue: [^ true].
	editSelection == #editMessageCategories 
		ifTrue: [^ self changeMessageCategories: aString].
	editSelection == #editMessage | (editSelection == #newMessage) 
		ifTrue: [^ self defineMessage: aText notifying: aController].
	editSelection == #none
		ifTrue: [PopUpMenu notify: 'This text cannot be accepted
in this part of the browser.'.
				^ false].
	self error: 'unacceptable accept'! !

!Browser methodsFor: 'accessing' stamp: 'tk 4/2/98 13:33'!
contentsSelection
	"Return the interval of text in the code pane to select when I set the pane's contents"

	messageCategoryListIndex > 0 & (messageListIndex = 0) 
		ifTrue: [^ 1 to: 500]	"entire empty method template"
		ifFalse: [^ 1 to: 0]  "null selection"! !

!Browser methodsFor: 'accessing' stamp: 'di 5/6/1998 20:57'!
couldBrowseAnyClass
	"Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name.  This implementation is clearly ugly, but the feature it enables is handsome enough.  3/1/96 sw"

	self dependents
		detect: [:d |
			(d class == PluggableListView) and: 
			[d getListSelector == #systemCategoryList]]
		ifNone: [^ false].
	^ true
! !

!Browser methodsFor: 'accessing'!
doItReceiver
	"This class's classPool has been jimmied to be the classPool of the class being browsed.  A doIt in the code pane will let the user see the value of the class variables."
	^ FakeClassPool new! !

!Browser methodsFor: 'accessing'!
editSelection
	^editSelection! !

!Browser methodsFor: 'accessing' stamp: 'jm 4/28/1998 05:55'!
request: prompt initialAnswer: initialAnswer

	^ FillInTheBlank
		request: prompt
		initialAnswer: initialAnswer
! !

!Browser methodsFor: 'accessing' stamp: 'di 5/20/1998 22:48'!
spawn: aString 
	"Create and schedule a new browser as though the command browse were 
	issued with respect to one of the browser's lists. The initial textual 
	contents is aString, which is the (modified) textual contents of the 
	receiver."

	messageListIndex ~= 0 
		ifTrue: [^self buildMessageBrowserEditString: aString].
	messageCategoryListIndex ~= 0 
		ifTrue: [^self buildMessageCategoryBrowserEditString: aString].
	classListIndex ~= 0 ifTrue: [^self buildClassBrowserEditString: aString].
	systemCategoryListIndex ~= 0 
		ifTrue: [^self buildSystemCategoryBrowserEditString: aString].
	^Browser new openEditString: aString! !


!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'!
indexIsOne
	"When used as a singleton list, index is always one"
	^ 1! !

!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'!
indexIsOne: value
	"When used as a singleton list, can't change it"

	^ self! !

!Browser methodsFor: 'system category list'!
selectedSystemCategoryName
	"Answer the name of the selected system category or nil."

	systemCategoryListIndex = 0 ifTrue: [^nil].
	^self systemCategoryList at: systemCategoryListIndex! !

!Browser methodsFor: 'system category list'!
systemCategoryList
	"Answer the class categories modelled by the receiver."

	^systemOrganizer categories! !

!Browser methodsFor: 'system category list'!
systemCategoryListIndex
	"Answer the index of the selected class category."

	^systemCategoryListIndex! !

!Browser methodsFor: 'system category list' stamp: 'tk 4/2/98 13:41'!
systemCategoryListIndex: anInteger 
	"Set the selected system category index to be anInteger. Update all other 
	selections to be deselected."

	systemCategoryListIndex _ anInteger.
	classListIndex _ 0.
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	editSelection _ anInteger = 0 ifTrue: [#none] ifFalse: [#newClass].
	metaClassIndicated _ false.
	self setClassOrganizer.
	contents _ nil.
	self changed: #systemCategorySelectionChanged.
	self changed: #systemCategoryListIndex.	"update my selection"
	self changed: #classList.
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #contents.
! !

!Browser methodsFor: 'system category list' stamp: 'tk 4/3/98 10:30'!
systemCategorySingleton

	| cat |
	cat _ self selectedSystemCategoryName.
	^ cat ifNil: [Array new]
		ifNotNil: [Array with: cat]! !

!Browser methodsFor: 'system category list'!
toggleSystemCategoryListIndex: anInteger 
	"If anInteger is the current system category index, deselect it. Else make 
	it the current system category selection."

	self systemCategoryListIndex: 
		(systemCategoryListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !


!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:56'!
addSystemCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex newName |
	self okToChange ifFalse: [^ self].
	oldIndex _ systemCategoryListIndex.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: 'Category-Name'.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	systemOrganizer
		addCategory: newName
		before: (systemCategoryListIndex = 0
				ifTrue: [nil]
				ifFalse: [self selectedSystemCategoryName]).
	self systemCategoryListIndex:
		(oldIndex = 0
			ifTrue: [systemOrganizer categories size]
			ifFalse: [oldIndex]).
	self changed: #systemCategoryList.! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/6/98 21:09'!
browseAllClasses
	"Create and schedule a new browser on all classes alphabetically."
	| newBrowser |
	newBrowser _ HierarchyBrowser new initAlphabeticListing.
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: 'All Classes Alphabetically'! !

!Browser methodsFor: 'system category functions'!
buildSystemCategoryBrowser
	"Create and schedule a new system category browser."

	self buildSystemCategoryBrowserEditString: nil! !

!Browser methodsFor: 'system category functions' stamp: 'tk 5/4/1998 15:56'!
buildSystemCategoryBrowserEditString: aString 
	"Create and schedule a new system category browser with initial textual 
	contents set to aString."

	| newBrowser |
	systemCategoryListIndex > 0
		ifTrue: 
			[newBrowser _ Browser new.
			newBrowser systemCategoryListIndex: systemCategoryListIndex.
			newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName.
			Browser openBrowserView: (newBrowser openSystemCatEditString: aString)
				label: 'Classes in category ', newBrowser selectedSystemCategoryName]! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:21'!
changeSystemCategories: aString 
	"Update the class categories by parsing the argument aString."

	systemOrganizer changeFromString: aString.
	self changed: #systemCategoryList.
	^ true! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:43'!
classNotFound

	self changed: #flash.! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:44'!
editSystemCategories
	"Retrieve the description of the class categories of the system organizer."

	self okToChange ifFalse: [^ self].
	self systemCategoryListIndex: 0.
	editSelection _ #editSystemCategories.
	self changed: #editSystemCategories.
	self changed: #contents! !

!Browser methodsFor: 'system category functions' stamp: 'tk 3/31/98 07:52'!
fileOutSystemCategory
	"Print a description of each class in the selected category onto a file 
	whose name is the category name followed by .st."

	systemCategoryListIndex ~= 0
		ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName]! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:44'!
findClass
	"Search for a class by name.  Modified so that if only 1 class matches the user-supplied string, or if the user-supplied string exactly matches a class name, then the pop-up menu is bypassed"
	| pattern foundClass classNames index reply |

	self okToChange ifFalse: [^ self classNotFound].
	pattern _ (reply _ FillInTheBlank request: 'Class Name?') asLowercase.
	pattern isEmpty ifTrue: [^ self classNotFound].
	(Smalltalk hasClassNamed: reply)
		ifTrue:
			[foundClass _ Smalltalk at: reply asSymbol]
		ifFalse:
 			[classNames _ Smalltalk classNames asArray select: 
				[:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0].
			classNames isEmpty ifTrue: [^ self classNotFound].
			index _ classNames size == 1
				ifTrue:	[1]
				ifFalse:	[(PopUpMenu labelArray: classNames lines: #()) startUp].
			index = 0 ifTrue: [^ self classNotFound].
			foundClass _ Smalltalk at: (classNames at: index)].
 	self systemCategoryListIndex: (self systemCategoryList indexOf: foundClass category).
	self classListIndex: (self classList indexOf: foundClass name). 
! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:46'!
printOutSystemCategory
	"Print a description of each class in the selected category as Html."

Cursor write showWhile:
	[systemCategoryListIndex ~= 0
		ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName
								asHtml: true ]]
! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'!
removeSystemCategory
	"If a class category is selected, create a Confirmer so the user can 
	verify that the currently selected class category and all of its classes
 	should be removed from the system. If so, remove it."

	systemCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(self classList size = 0
		or: [self confirm: 'Are you sure you want to
remove this system category 
and all its classes?'])
		ifTrue: 
		[systemOrganizer removeSystemCategory: self selectedSystemCategoryName.
		self systemCategoryListIndex: 0.
		self changed: #systemCategoryList]! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'!
renameSystemCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex oldName newName |
	(oldIndex _ systemCategoryListIndex) = 0
		ifTrue: [^ self].  "no selection"
	self okToChange ifFalse: [^ self].
	oldName _ self selectedSystemCategoryName.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: oldName.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	oldName = newName ifTrue: [^ self].
	systemOrganizer
		renameCategory: oldName
		toBe: newName.
	self systemCategoryListIndex: oldIndex.
	self changed: #systemCategoryList.! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:48'!
systemCategoryMenu: aMenu

^ aMenu labels:
'find class...
recent classes...
browse all
browse
printOut
fileOut
reorganize
update
add item...
rename...
remove' 
	lines: #(2 4 6 8)
	selections:
		#(findClass recent browseAllClasses buildSystemCategoryBrowser
		printOutSystemCategory fileOutSystemCategory
		editSystemCategories updateSystemCategories
		addSystemCategory renameSystemCategory removeSystemCategory )
! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:17'!
updateSystemCategories
	"The class categories were changed in another browser. The receiver must 
	reorganize its lists based on these changes."

	self okToChange ifFalse: [^ self].
	self changed: #systemCategoryList! !


!Browser methodsFor: 'class list'!
classList
	"Answer an array of the class names of the selected category. Answer an 
	empty array if no selection exists."

	systemCategoryListIndex = 0
		ifTrue: [^Array new]
		ifFalse: [^systemOrganizer listAtCategoryNumber: systemCategoryListIndex]! !

!Browser methodsFor: 'class list'!
classListIndex
	"Answer the index of the current class selection."

	^classListIndex! !

!Browser methodsFor: 'class list' stamp: 'tk 4/2/98 13:30'!
classListIndex: anInteger 
	"Set anInteger to be the index of the current class selection."

	| className |
	classListIndex _ anInteger.
	self setClassOrganizer.
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	self classCommentIndicated
		ifTrue: []
		ifFalse: [editSelection _ anInteger = 0
					ifTrue: [metaClassIndicated
						ifTrue: [#none]
						ifFalse: [#newClass]]
					ifFalse: [#editClass]].
	contents _ nil.
	self selectedClass isNil
		ifFalse: [className _ self selectedClass name.
					(RecentClasses includes: className)
				ifTrue: [RecentClasses remove: className].
			RecentClasses addFirst: className.
			RecentClasses size > 16
				ifTrue: [RecentClasses removeLast]].
	self changed: #classSelectionChanged.
	self changed: #classListIndex.	"update my selection"
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #contents.
! !

!Browser methodsFor: 'class list' stamp: 'tk 4/5/98 12:25'!
classListSingleton

	| name |
	name _ self selectedClassName.
	^ name ifNil: [Array new]
		ifNotNil: [Array with: name]! !

!Browser methodsFor: 'class list' stamp: 'sw 12/19/96'!
recent
	"Let the user select from a list of recently visited classes.  11/96 stp.
	 12/96 di:  use class name, not classes themselves.
	 : dont fall into debugger in empty case"

	| className class recentList |
	recentList _ RecentClasses select: [:n | Smalltalk includesKey: n].
	recentList size == 0 ifTrue: [^ self beep].
	className := (SelectionMenu selections: recentList) startUp.
	className == nil ifTrue: [^ self].
	class := Smalltalk at: className.
	self systemCategoryListIndex: (self systemCategoryList indexOf: class category).
	self classListIndex: (self classList indexOf: class name)! !

!Browser methodsFor: 'class list'!
selectClass: classNotMeta
	self classListIndex: (self classList findFirst: [:each | each == classNotMeta name])! !

!Browser methodsFor: 'class list' stamp: 'tk 4/4/98 18:48'!
selectedClass
	"Answer the class that is currently selected. Answer nil if no selection 
	exists."

	| name |
	(name _ self selectedClassName) ifNil: [^ nil].
	^ Smalltalk at: name! !

!Browser methodsFor: 'class list'!
selectedClassName
	"Answer the name of the current class. Answer nil if no selection exists."

	classListIndex = 0 ifTrue: [^nil].
	^self classList at: classListIndex! !

!Browser methodsFor: 'class list'!
toggleClassListIndex: anInteger 
	"If anInteger is the current class index, deselect it. Else make it the 
	current class selection."

	self classListIndex: 
		(classListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !


!Browser methodsFor: 'class functions'!
buildClassBrowser
	"Create and schedule a new class category browser for the current class 
	selection, if one exists."

	self buildClassBrowserEditString: nil! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/7/98 13:15'!
buildClassBrowserEditString: aString 
	"Create and schedule a new class browser for the current selection, if one 
	exists, with initial textual contents set to aString."

	| newBrowser |
	self selectedClass ifNotNil:
		[newBrowser _ Browser new.
		newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName.
		Browser openBrowserView: (newBrowser openOnClassWithEditString: aString)
			label: 'Class Browser: ', self selectedClassOrMetaClass name]
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/10/1998 12:44'!
classListMenu: aMenu

^ aMenu labels: 
'browse class
browse full
printOut
fileOut
hierarchy
definition
comment
spawn hierarchy
spawn protocol
inst var refs..
inst var defs..
class var refs...
class vars
class refs
rename...
remove
unsent methods
find method...' 
	lines: #(4 7 9 11 14 16)
	selections:
		#(buildClassBrowser browseMethodFull printOutClass fileOutClass
		hierarchy editClass editComment
		spawnHierarchy spawnProtocol
		browseInstVarRefs browseInstVarDefs browseClassVarRefs 
		browseClassVariables browseClassRefs
		renameClass removeClass browseUnusedMethods findMethod)
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:52'!
defineClass: aString notifying: aController 
	"The receiver's textual content is a request to define a new class. The 
	source code is aString. If any errors occur in compilation, notify 
	aController."

	| oldClass class |
	oldClass _ self selectedClassOrMetaClass.
	oldClass isNil ifTrue: [oldClass _ Object].
	class _ oldClass subclassDefinerClass
				evaluate: aString
				notifying: aController
				logged: true.
	(class isKindOf: Behavior)
		ifTrue: 
			[self changed: #classList.
			self classListIndex: 
				(self classList indexOf: 
					((class isKindOf: Metaclass)
						ifTrue: [class soleInstance name]
						ifFalse: [class name])).
			self clearUserEditFlag; editClass.
			^true]
		ifFalse: [^false]! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:49'!
editClass
	"Retrieve the description of the class definition."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection _ #editClass.
	self changed: #editClass.
	self changed: #contents.
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:49'!
editComment
	"Retrieve the description of the class comment."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection _ #editComment.
	self changed: #classSelectionChanged.
	self changed: #contents.
! !

!Browser methodsFor: 'class functions'!
explainSpecial: string 
	"Answer a string explaining the code pane selection if it is displaying 
	one of the special edit functions."

	| classes whole lits reply |
	(editSelection == #editClass or: [editSelection == #newClass])
		ifTrue: 
			["Selector parts in class definition"
			string last == $: ifFalse: [^nil].
			lits _ Array with:
				#subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:.
			(whole _ lits detect: [:each | (each keywords
					detect: [:frag | frag = string] ifNone: []) ~~ nil]
						ifNone: []) ~~ nil
				ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.']
				ifFalse: [^nil].
			classes _ Smalltalk allClassesImplementing: whole.
			classes _ 'these classes ' , classes printString.
			^reply , '  It is defined in ' , classes , '."
Smalltalk browseAllImplementorsOf: #' , whole].

	editSelection == #hierarchy
		ifTrue: 
			["Instance variables in subclasses"
			classes _ self selectedClassOrMetaClass allSubclasses.
			classes _ classes detect: [:each | (each instVarNames
						detect: [:name | name = string] ifNone: []) ~~ nil]
					ifNone: [^nil].
			classes _ classes printString.
			^'"is an instance variable in class ' , classes , '."
' , classes , ' browseAllAccessesTo: ''' , string , '''.'].
	editSelection == #editSystemCategories ifTrue: [^nil].
	editSelection == #editMessageCategories ifTrue: [^nil].
	^nil! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
fileOutClass
	"Print a description of the selected class onto a file whose name is the 
	category name followed by .st."

Cursor write showWhile:
		[classListIndex ~= 0 ifTrue: [self selectedClass fileOut]]! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
findMethod
	"Pop up a list of the current class's methods, and select the one chosen by the user.
	5/21/96 sw, based on a suggestion of John Maloney's."
	| aClass selectors reply cat messageCatIndex messageIndex |

	self classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	aClass _ self selectedClassOrMetaClass.
	selectors _ aClass selectors asSortedArray.
	reply _ (SelectionMenu labelList: selectors selections: selectors) startUp.
	reply == nil ifTrue: [^ self].
	cat _ aClass whichCategoryIncludesSelector: reply.
	messageCatIndex _ self messageCategoryList indexOf: cat.
	self messageCategoryListIndex: messageCatIndex.
	messageIndex _ (self messageList indexOf: reply).
	self messageListIndex: messageIndex.
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
hierarchy
	"Display the inheritance hierarchy of the receiver's selected class."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection := #hierarchy.
	self changed: #editComment.
	self changed: #contents.
	^ self! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
printOutClass
	"Print a description of the selected class onto a file whose name is the 
	category name followed by .html."

Cursor write showWhile:
		[classListIndex ~= 0 ifTrue: [self selectedClass fileOutAsHtml: true]]! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:52'!
removeClass
	"The selected class should be removed from the system. Use a Confirmer 
	to make certain the user intends this irrevocable command to be carried 
	out."
	| message class className |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	class _ self selectedClass.
	className _ class name.
	message _ 'Are you certain that you
want to delete the class ', className, '?'.
	(self confirm: message) ifTrue: 
			[class subclasses size > 0
				ifTrue: [self notify: 'class has subclasses: ' , message].
			class removeFromSystem.
			self classListIndex: 0].
	self changed: #classList.
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:54'!
renameClass
	| oldName newName obs |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	oldName _ self selectedClass name.
	newName _ (self request: 'Please type new class name'
						initialAnswer: oldName) asSymbol.
	newName = oldName ifTrue: [^ self].
	(Smalltalk includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists'].
	self selectedClass rename: newName.
	self changed: #classList.
	self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName).
	obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName).
	obs isEmpty ifFalse:
		[Smalltalk browseMessageList: obs
			name: 'Obsolete References to ' , oldName
			autoSelect: oldName].
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/7/98 13:25'!
spawnHierarchy
	"Create and schedule a new class hierarchy browser on the currently selected class or meta."
	| newBrowser aSymbol aBehavior messageCatIndex |
	classListIndex = 0 ifTrue: [^ self].
	newBrowser _ HierarchyBrowser new initHierarchyForClass: self selectedClass 
			meta: self metaClassIndicated.
	(aSymbol _ self selectedMessageName) ifNotNil: [
		aBehavior _ self selectedClassOrMetaClass.
		messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol.
		newBrowser messageCategoryListIndex: messageCatIndex.
		newBrowser messageListIndex:
			((aBehavior organization listAtCategoryNumber: messageCatIndex)
						indexOf: aSymbol)].
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: self selectedClassName , ' hierarchy'! !

!Browser methodsFor: 'class functions' stamp: 'di 7/13/97 16:43'!
spawnProtocol
        "Create and schedule a new protocol browser on the currently selected class or meta."
        classListIndex = 0 ifTrue: [^ self].
        ProtocolBrowser openSubProtocolForClass: self selectedClassOrMetaClass  ! !


!Browser methodsFor: 'message category list' stamp: 'tk 4/5/98 12:25'!
messageCatListSingleton

	| name |
	name _ self selectedMessageCategoryName.
	^ name ifNil: [Array new]
		ifNotNil: [Array with: name]! !

!Browser methodsFor: 'message category list'!
messageCategoryList
	"Answer the selected category of messages."

	classListIndex = 0
		ifTrue: [^Array new]
		ifFalse: [^self classOrMetaClassOrganizer categories]! !

!Browser methodsFor: 'message category list'!
messageCategoryListIndex
	"Answer the index of the selected message category."

	^messageCategoryListIndex! !

!Browser methodsFor: 'message category list' stamp: 'tk 4/2/98 13:41'!
messageCategoryListIndex: anInteger 
	"Set the selected message category to be the one indexed by anInteger."

	messageCategoryListIndex _ anInteger.
	messageListIndex _ 0.
	editSelection _ 
		anInteger = 0
			ifTrue: [#none]
			ifFalse: [#newMessage].
	contents _ nil.
	self changed: #messageCategorySelectionChanged.
	self changed: #messageCategoryListIndex.	"update my selection"
	self changed: #messageList.
	self changed: #contents.
! !

!Browser methodsFor: 'message category list'!
selectedMessageCategoryName
	"Answer the name of the selected message category, if any. Answer nil 
	otherwise."

	messageCategoryListIndex = 0 ifTrue: [^nil].
	^self messageCategoryList at: messageCategoryListIndex! !

!Browser methodsFor: 'message category list'!
toggleMessageCategoryListIndex: anInteger 
	"If the currently selected message category index is anInteger, deselect 
	the category. Otherwise select the category whose index is anInteger."

	self messageCategoryListIndex: 
		(messageCategoryListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !


!Browser methodsFor: 'message category functions' stamp: 'di 5/19/1998 23:58'!
addCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex newName |
	self okToChange ifFalse: [^ self].
	classListIndex = 0 ifTrue: [^ self].
	oldIndex _ messageCategoryListIndex.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: 'category name'.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	self classOrMetaClassOrganizer
		addCategory: newName
		before: (messageCategoryListIndex = 0
				ifTrue: [nil]
				ifFalse: [self selectedMessageCategoryName]).
	self changed: #messageCategoryList.
	self messageCategoryListIndex:
		(oldIndex = 0
			ifTrue: [self classOrMetaClassOrganizer categories size]
			ifFalse: [oldIndex]).
	self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions'!
buildMessageCategoryBrowser
	"Create and schedule a message category browser for the currently 
	selected message category."

	self buildMessageCategoryBrowserEditString: nil! !

!Browser methodsFor: 'message category functions' stamp: 'tk 5/6/1998 21:30'!
buildMessageCategoryBrowserEditString: aString 
	"Create and schedule a message category browser for the currently 
	selected	 message category. The initial text view contains the characters 
	in aString."

	| newBrowser |
	messageCategoryListIndex ~= 0
		ifTrue: 
			[newBrowser _ Browser new.
			newBrowser systemCategoryListIndex: systemCategoryListIndex.
			newBrowser classListIndex: classListIndex.
			newBrowser metaClassIndicated: metaClassIndicated.
			newBrowser messageCategoryListIndex: messageCategoryListIndex.
			newBrowser messageListIndex: messageListIndex.
			Browser openBrowserView: (newBrowser openMessageCatEditString: aString)
				label: 'Message Category Browser (' , 
						newBrowser selectedClassOrMetaClassName , ')']! !

!Browser methodsFor: 'message category functions' stamp: 'jm 3/24/98 16:05'!
changeMessageCategories: aString 
	"The characters in aString represent an edited version of the the message 
	categories for the selected class. Update this information in the system 
	and inform any dependents that the categories have been changed. This 
	message is invoked because the user had issued the categories command 
	and edited the message categories. Then the user issued the accept 
	command."

	self classOrMetaClassOrganizer changeFromString: aString.
	Smalltalk changes reorganizeClass: self selectedClassOrMetaClass.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
editMessageCategories
	"Indicate to the receiver and its dependents that the message categories of 
	the selected class have been changed."

	self okToChange ifFalse: [^ self].
	classListIndex ~= 0
		ifTrue: 
			[self messageCategoryListIndex: 0.
			editSelection _ #editMessageCategories.
			self changed: #editMessageCategories.
			self changed: #contents]! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
fileOutMessageCategories
	"Print a description of the selected message category of the selected class 
	onto an external file."

Cursor write showWhile:
	[messageCategoryListIndex ~= 0
		ifTrue: 
			[self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
messageCategoryMenu: aMenu

^ aMenu labels:
'browse
printOut
fileOut
reorganize
add item...
rename...
remove'
	lines: #(3 4)
	selections:
		#(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories
		editMessageCategories
		addCategory renameCategory removeMessageCategory)
! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
printOutMessageCategories
	"Print a description of the selected message category of the selected class 
	onto an external file in Html format."

Cursor write showWhile:
	[messageCategoryListIndex ~= 0
		ifTrue: 
			[self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName
										asHtml: true]]! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:54'!
removeMessageCategory
	"If a message category is selected, create a Confirmer so the user can 
	verify that the currently selected message category should be removed
 	from the system. If so, remove it."

	| messageCategoryName |
	messageCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageCategoryName _ self selectedMessageCategoryName.
	(self messageList size = 0
		or: [self confirm: 'Are you sure you want to
remove this method category 
and all its methods?'])
		ifTrue: 
			[self selectedClassOrMetaClass removeCategory: messageCategoryName.
			self messageCategoryListIndex: 0.
			self changed: #classSelectionChanged].
	self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:54'!
renameCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex oldName newName |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self].
	oldName _ self selectedMessageCategoryName.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: oldName.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	newName = oldName ifTrue: [^ self].
	self classOrMetaClassOrganizer
		renameCategory: oldName
		toBe: newName.
	Smalltalk changes reorganizeClass: self selectedClassOrMetaClass.
	self classListIndex: classListIndex.
	self messageCategoryListIndex: oldIndex.
	self changed: #messageCategoryList.
! !


!Browser methodsFor: 'message list'!
messageList
	"Answer an Array of the message selectors of the currently selected 
	message category. Otherwise, answer a new empty Array."

	messageCategoryListIndex = 0
		ifTrue: [^Array new]
		ifFalse: [^self classOrMetaClassOrganizer 
					listAtCategoryNumber: messageCategoryListIndex]! !

!Browser methodsFor: 'message list'!
messageListIndex
	"Answer the index of the selected message selector into the currently 
	selected message category."

	^messageListIndex! !

!Browser methodsFor: 'message list' stamp: 'tk 4/25/1998 00:11'!
messageListIndex: anInteger 
	"Set the selected message selector to be the one indexed by anInteger."

	messageListIndex _ anInteger.
	editSelection _ 
		anInteger = 0
			ifTrue: [#newMessage]
			ifFalse: [#editMessage].
	contents _ nil.
	self changed: #messageListIndex.	"update my selection"
	self changed: #contents.
! !

!Browser methodsFor: 'message list' stamp: 'tk 4/6/98 10:48'!
messageListSingleton

	| name |
	name _ self selectedMessageName.
	^ name ifNil: [Array new]
		ifNotNil: [Array with: name]! !

!Browser methodsFor: 'message list' stamp: 'tk 4/4/98 21:25'!
selectedMessage
	"Answer a copy of the source code for the selected message selector."
	| class selector method tempNames |
	contents == nil ifFalse: [^ contents copy].
	class _ self selectedClassOrMetaClass.
	selector _ self selectedMessageName.
	method _ class compiledMethodAt: selector.

	(Sensor controlKeyPressed
		or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) == nil]])
		ifTrue:
		["Emergency or no source file -- decompile without temp names"
		contents _ (class decompilerClass new decompile: selector in: class method: method)
			decompileString.
		^ contents copy].

	Sensor leftShiftDown ifTrue:
		["Special request to decompile -- get temps from source file"
		tempNames _ (class compilerClass new
						parse: method getSourceFromFile asString in: class notifying: nil)
						tempNames.
		contents _ ((class decompilerClass new withTempNames: tempNames)
				decompile: selector
				in: class
				method: method) decompileString.
		contents _ contents asText makeSelectorBoldIn: self selectedClassOrMetaClass.
		^ contents copy].

	contents _ class sourceCodeAt: selector.
	contents _ contents asText makeSelectorBoldIn: self selectedClassOrMetaClass.
	^ contents copy! !

!Browser methodsFor: 'message list'!
selectedMessageName
	"Answer the message selector of the currently selected message, if any. 
	Answer nil otherwise."

	messageListIndex = 0 ifTrue: [^nil].
	^self messageList at: messageListIndex! !

!Browser methodsFor: 'message list'!
toggleMessageListIndex: anInteger 
	"If the currently selected message index is anInteger, deselect the message 
	selector. Otherwise select the message selector whose index is anInteger."

	self messageListIndex: 
		(messageListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !


!Browser methodsFor: 'message functions'!
browseImplementors
	"Create and schedule a message set browser on all implementors of the 
	currently selected message selector. Do nothing if no message is selected."

	messageListIndex ~= 0 
		ifTrue: [Smalltalk browseAllImplementorsOf: self selectedMessageName]! !

!Browser methodsFor: 'message functions'!
buildMessageBrowser
	"Create and schedule a message browser on the currently selected 
	message. Do nothing if no message is selected. The initial text view 
	contains nothing."

	self buildMessageBrowserEditString: nil! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/6/98 21:47'!
buildMessageBrowserEditString: aString 
	"Create and schedule a message browser for the receiver in which the 
	argument, aString, contains characters to be edited in the text view."

	messageListIndex = 0 ifTrue: [^ self].
	^ Browser openMessageBrowserForClass: self selectedClassOrMetaClass 
		selector: self selectedMessageName editString: aString! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/25/1998 00:08'!
defineMessage: aString notifying: aController 
	"Compile the expressions in aString. Notify aController if a syntax error 
	occurs. Install the compiled method in the selected class classified under 
	the currently selected message category name. Answer true if 
	compilation succeeds, false otherwise."
	| selectedMessageName selector category oldMessageList |
	selectedMessageName _ self selectedMessageName.
	oldMessageList _ self messageList.
	contents _ nil.
	selector _ self selectedClassOrMetaClass
				compile: aString
				classified: (category _ self selectedMessageCategoryName)
				notifying: aController.
	selector == nil ifTrue: [^ false].
	contents _ aString copy.
	selector ~~ selectedMessageName
		ifTrue: 
			[category = ClassOrganizer nullCategory
				ifTrue: [self changed: #classSelectionChanged.
						self changed: #classList.
						self messageCategoryListIndex: 1].
			self setClassOrganizer.  "In case organization not cached"
			(oldMessageList includes: selector)
				ifFalse: [self changed: #messageList].
			self messageListIndex: (self messageList indexOf: selector)].
	^ true! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:02'!
inspectInstances
	"Inspect all instances of the selected class.  1/26/96 sw"

	| myClass |
	myClass _ self selectedClassOrMetaClass.
	myClass ~~ nil ifTrue:
		[myClass theNonMetaClass inspectAllInstances].
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:02'!
inspectSubInstances
	"Inspect all instances of the selected class and all its subclasses  1/26/96 sw"

	| aClass |
	aClass _ self selectedClassOrMetaClass.
	aClass ~~ nil ifTrue:
		[aClass _ aClass theNonMetaClass.
		 aClass inspectSubInstances].
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/18/1998 16:14'!
messageListMenu: aMenu shifted: shifted
	^ shifted ifFalse: [aMenu labels:
'browse full
fileOut
printOut
senders of...
implementors of...
method inheritance
versions
inst var refs...
inst var defs...
class var refs...
class variables
class refs
remove
more...'
	lines: #(3 7 12)
	selections:
		#(browseMethodFull fileOutMessage printOutMessage
		browseSendersOfMessages browseMessages methodHierarchy browseVersions
		browseInstVarRefs browseInstVarDefs browseClassVarRefs 
			browseClassVariables browseClassRefs
		removeMessage shiftedYellowButtonActivity )]

	ifTrue: [aMenu labels: 'browse class hierarchy
browse class
browse method
implementors of sent messages
change sets with this method
inspect instances
inspect subinstances
remove from this browser
revert to previous version
remove from current change set
revert and forget
more...' 
	lines: #(5 7 11)
	selections: #(classHierarchy browseClass 
		buildMessageBrowser browseAllMessages findMethodInChangeSets 
		inspectInstances inspectSubInstances
		removeMessageFromBrowser revertToPreviousVersion 
		removeFromCurrentChanges revertAndForget
		unshiftedYellowButtonActivity)]
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'!
removeFromCurrentChanges
	"Tell the changes mgr to forget that the current msg was changed."

	Smalltalk changes removeSelectorChanges: self selectedMessageName 
			class: self selectedClassOrMetaClass.
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/25/1998 00:07'!
removeMessage
	"If a message is selected, create a Confirmer so the user can verify that 
	the currently selected message should be removed from the system. If so, 
	remove it.  If the Preference 'confirmMethodRemoves' is set to false, the 
	confirmer is bypassed."
	| messageName confirmation |

	messageListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageName _ self selectedMessageName.
	confirmation _ self selectedClassOrMetaClass confirmRemovalOf: messageName.
	confirmation == 3 ifTrue: [^ self].

	self selectedClassOrMetaClass removeSelector: self selectedMessageName.
	self changed: #messageList.
	self messageListIndex: 0.
	self setClassOrganizer.  "In case organization not cached"

	confirmation == 2 ifTrue:
		[Smalltalk browseAllCallsOn: messageName]
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'!
removeMessageFromBrowser
	"Our list speaks the truth and can't have arbitrary things removed"

	^ self changed: #flash! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/24/1998 23:46'!
revertAndForget
	"Revert to the previous version of the current method, and tell the changes mgr to forget that it was ever changed.  Danger!!  Use only if you really know what you're doing!!"

	self revertToPreviousVersion.
	self removeFromCurrentChanges.
	self changed: #contents! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:04'!
revertToPreviousVersion
	"Revert to the previous version of the current method"

	| aClass aSelector  changeRecords codeController |
	aClass _ self selectedClassOrMetaClass.
	aClass ifNil: [^ self changed: #flash].
	aSelector _ self selectedMessageName.
	changeRecords _ aClass changeRecordsAt: aSelector.
	changeRecords size <= 1 ifTrue: [self changed: #flash.  ^ self beep].
	codeController _ (self dependents detect: [:v | v isKindOf: PluggableTextView]) controller.
		"later find a better way to do this!!"
	self contents: (changeRecords at: 2) string notifying: codeController.
	self changed: #contents! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 20:57'!
shiftedYellowButtonActivity
	"Invoke the model's other menu.  Just do what the controller would have done."

	| menu |
	menu _ self messageListMenu: (CustomMenu new) shifted: true.
	menu == nil
		ifTrue: [Sensor waitNoButton]
		ifFalse: [menu invokeOn: self].
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 20:58'!
unshiftedYellowButtonActivity
	"Invoke the model's other menu.  Just do what the controller would have done."

	| menu |
	menu _ self messageListMenu: (CustomMenu new) shifted: false.
	menu == nil
		ifTrue: [Sensor waitNoButton]
		ifFalse: [menu invokeOn: self].
! !


!Browser methodsFor: 'code pane' stamp: 'tk 4/9/98 14:03'!
showBytecodes
	"Show the bytecodes of the selected method."
	"Set a mode for contents!!"

	((self messageListIndex = 0) | (self okToChange not))
		ifTrue: [^ self changed: #flash].
	editSelection _ #byteCodes.
	self changed: #contents.
! !


!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 12:25'!
classCommentIndicated
	"Answer true iff we're viewing the class comment."

	^ editSelection == #editComment 
! !

!Browser methodsFor: 'metaclass'!
classMessagesIndicated
	"Answer whether the messages to be presented should come from the 
	metaclass."

	^ self metaClassIndicated! !

!Browser methodsFor: 'metaclass'!
classOrMetaClassOrganizer
	"Answer the class organizer for the metaclass or class, depending on 
	which (instance or class) is indicated."

	self metaClassIndicated
		ifTrue: [^metaClassOrganizer]
		ifFalse: [^classOrganizer]! !

!Browser methodsFor: 'metaclass'!
indicateClassMessages
	"Indicate that the message selection should come from the metaclass 
	messages."

	self metaClassIndicated: true! !

!Browser methodsFor: 'metaclass'!
indicateInstanceMessages
	"Indicate that the message selection should come from the class (instance) 
	messages."

	self metaClassIndicated: false! !

!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:20'!
instanceMessagesIndicated
	"Answer whether the messages to be presented should come from the 
	class."

	^metaClassIndicated not and: [self classCommentIndicated not]! !

!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:19'!
metaClassIndicated
	"Answer the boolean flag that indicates which of the method dictionaries, 
	class or metaclass."

	^ metaClassIndicated and: [self classCommentIndicated not]! !

!Browser methodsFor: 'metaclass' stamp: 'tk 4/2/98 17:05'!
metaClassIndicated: trueOrFalse 
	"Indicate whether browsing instance or class messages."
	metaClassIndicated _ trueOrFalse.
	self setClassOrganizer.
	systemCategoryListIndex > 0 ifTrue:
		[editSelection _ classListIndex = 0
			ifTrue: [metaClassIndicated
				ifTrue: [#none]
				ifFalse: [#newClass]]
			ifFalse: [#editClass]].
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	contents _ nil.
	self changed: #classSelectionChanged.
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #contents.
! !

!Browser methodsFor: 'metaclass' stamp: 'tk 4/9/98 10:48'!
selectedClassOrMetaClass
	"Answer the selected class or metaclass."

	| cls |
	self metaClassIndicated
		ifTrue: [^ (cls _ self selectedClass) ifNil: [nil] ifNotNil: [cls class]]
		ifFalse: [^ self selectedClass]! !

!Browser methodsFor: 'metaclass'!
selectedClassOrMetaClassName
	"Answer the selected class name or metaclass name."

	^self selectedClassOrMetaClass name! !

!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:27'!
setClassOrganizer
	"Install whatever organization is appropriate"
	| theClass |
	classOrganizer _ nil.
	metaClassOrganizer _ nil.
	classListIndex = 0 ifTrue: [^ self].
	classOrganizer _ (theClass _ self selectedClass) organization.
	metaClassOrganizer _ theClass class organization.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Browser class
	instanceVariableNames: ''!

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/10/1998 17:37'!
fullOnClass: aClass 
	"Open a new full browser set to class."
	| brow |
	brow _ Browser new.
	brow setClass: aClass selector: nil.
	Browser openBrowserView: (brow openEditString: nil)
		label: 'System Browser'! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 15:27'!
fullOnClass: aClass selector: aSelector
	"Open a new full browser set to class."

	| brow |
	brow _ Browser new.
	brow setClass: aClass selector: aSelector.
	Browser openBrowserView: (brow openEditString: nil)
		label: 'System Browser'! !

!Browser class methodsFor: 'instance creation'!
new

	^super new systemOrganizer: SystemOrganization! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 22:04'!
newOnCategory: aCategory
	"Browse the system category of the given name.  7/13/96 sw"

	"Browser newOnCategory: 'Interface-Browser'"

	| newBrowser catList |
	newBrowser _ Browser new.
	catList _ newBrowser systemCategoryList.
	newBrowser systemCategoryListIndex: 
		(catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']).
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
				label: 'Classes in category ', aCategory
! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:28'!
newOnClass: aClass 
	"Open a new class browser on this class."
	^ self newOnClass: aClass label: 'Class Browser: ', aClass name! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 22:55'!
newOnClass: aClass label: aLabel
	"Open a new class browser on this class."
	| newBrowser |

	newBrowser _ Browser new.
	newBrowser setClass: aClass selector: nil.
	Browser openBrowserView: (newBrowser openOnClassWithEditString: nil)
			label: aLabel
! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:29'!
newOnClass: aClass selector: aSymbol
	"Open a new class browser on this class."
	| newBrowser |

	newBrowser _ Browser new.
	newBrowser setClass: aClass selector: aSymbol.
	Browser openBrowserView: (newBrowser openOnClassWithEditString: nil)
			label: 'Class Browser: ', aClass name
! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 21:28'!
openBrowser
	"Create and schedule a BrowserView with label 'System Browser'. The 
	view consists of five subviews, starting with the list view of system 
	categories of SystemOrganization. The initial text view part is empty."

	Browser openBrowserView: (Browser new openEditString: nil)
			label: 'System Browser'
! !

!Browser class methodsFor: 'instance creation' stamp: 'di 5/14/1998 09:43'!
openBrowserView: aBrowserView label: aString 
	"Schedule aBrowserView, labelling the view aString."
	
	aBrowserView isMorph
		ifTrue:  [(aBrowserView setLabel: aString) openInWorld]
		ifFalse: [aBrowserView label: aString.
				aBrowserView minimumSize: 300 @ 200.
				aBrowserView subViews do: [:each | each controller].
				aBrowserView controller open]! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 21:44'!
openMessageBrowserForClass: aBehavior selector: aSymbol editString: aString
	"Create and schedule a message browser for the class, aBehavior, in 
	which the argument, aString, contains characters to be edited in the text 
	view. These characters are the source code for the message selector 
	aSymbol."

	| newBrowser |
	(newBrowser _ Browser new) setClass: aBehavior selector: aSymbol.
	^ Browser openBrowserView: (newBrowser openMessageEditString: aString)
		label: newBrowser selectedClassOrMetaClassName , ' ' , newBrowser selectedMessageName
! !


!Browser class methodsFor: 'class initialization'!
initialize
        "Browser initialize"

        RecentClasses := OrderedCollection new! !
Switch subclass: #Button
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Menus'!
!Button commentStamp: 'di 5/22/1998 16:32' prior: 0!
Button comment:
'I am a Switch that turns off automatically after being turned on, that is, I act like a push-button switch.'!


!Button methodsFor: 'state'!
turnOff
	"Sets the state of the receiver to 'off'. The off action of the receiver is not  
	executed."

	on _ false! !

!Button methodsFor: 'state'!
turnOn
	"The receiver remains in the 'off' state'."

	self doAction: onAction.
	self doAction: offAction! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Button class
	instanceVariableNames: ''!

!Button class methodsFor: 'instance creation'!
newOn 
	"Refer to the comment in Switch|newOn."

	self error: 'Buttons cannot be created in the on state'.
	^nil! !
SimpleButtonMorph subclass: #ButtonMorph
	instanceVariableNames: 'lastAcceptedScript lastScriptEditor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Experimental-Miscellaneous'!

!ButtonMorph methodsFor: 'menu' stamp: 'di 11/4/97 09:01'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'border color' action: #changeBorderColor:.
	aCustomMenu add: 'border width' action: #changeBorderWidth:.
	aCustomMenu add: 'change label' action: #setLabel.
	aCustomMenu add: 'script' action: #editScript:.
! !

!ButtonMorph methodsFor: 'menu'!
editScript: evt

	self nameInModel ifNil: [self choosePartNameSilently].
	evt hand attachMorph:
		(self scriptEditorFor: 'buttonUp').
! !

!ButtonMorph methodsFor: 'menu'!
hasScript
	"Return true if there is already a script for this morph."

	^ lastAcceptedScript ~~ nil! !

!ButtonMorph methodsFor: 'menu'!
scriptEditorFor: ignored

	(lastScriptEditor ~= nil and: [lastScriptEditor isInWorld])
		ifTrue: [^ lastScriptEditor].

	lastAcceptedScript = nil ifTrue: [
		^ lastScriptEditor _ ScriptEditorMorph new
			setMorph: self
			scriptName: 'ButtonUp'.
	] ifFalse: [
		^ lastScriptEditor _ lastAcceptedScript fullCopy].
! !


!ButtonMorph methodsFor: 'copying' stamp: 'tk 12/4/97 11:22'!
copy

	| obj |
	obj _ super copy.
	obj lastScriptEditor: obj lastAcceptedScript.	
		"lastScriptEditor would not have been copied, as it is owned by the world, not me.  Can't allow mine to creep into the copy." 
	^ obj! !

!ButtonMorph methodsFor: 'copying' stamp: 'sw 9/22/97 08:57'!
copyRecordingIn: dict
	"Overridden to copy lastAcceptedScript as well."

	| new |
	new _ super copyRecordingIn: dict.
	lastAcceptedScript ifNotNil: [
		new lastAcceptedScript: 
			((dict includesKey: lastAcceptedScript)
				ifTrue: [dict at: lastAcceptedScript]
				ifFalse: [lastAcceptedScript copyRecordingIn: dict])].
	lastScriptEditor ifNotNil: [
		new lastScriptEditor: 
			((dict includesKey: lastScriptEditor)
				ifTrue: [dict at: lastScriptEditor]
				ifFalse: [lastScriptEditor copyRecordingIn: dict])].
	^ new
! !

!ButtonMorph methodsFor: 'copying' stamp: 'tk 12/4/97 11:23'!
prepareToBeSaved
	"SmartRefStream will not write any morph that is owned by someone outside the root being written.  (See DataStream.typeIDFor:)  Open Scripts are like that.  Make a private copy of the scriptEditor."

	super prepareToBeSaved.
	lastAcceptedScript ifNotNil: [
		lastAcceptedScript owner ifNotNil: ["open on the screen"
			lastAcceptedScript _ lastAcceptedScript fullCopy setMorph: self.
			"lastAcceptedScript privateOwner: nil" "fullCopy does it"]].
	"lastScriptEditor will not be written out"! !

!ButtonMorph methodsFor: 'copying' stamp: 'tk 12/4/97 11:21'!
shallowCopy

	| obj |
	obj _ super shallowCopy.
	obj lastScriptEditor: obj lastAcceptedScript.	
		"lastScriptEditor would not have been copied, as it is owned by the world, not me.  Can't allow mine to creep into the copy." 
	^ obj! !


!ButtonMorph methodsFor: 'other'!
acceptScript: aScriptEditorMorph for: ignored

	lastAcceptedScript _ aScriptEditorMorph.
	self world model class
		compile: lastAcceptedScript methodString
		classified: 'scripts'
		notifying: nil.
! !

!ButtonMorph methodsFor: 'other'!
buttonUpSelector

	^ (self nameInModel, 'ButtonUp') asSymbol
! !

!ButtonMorph methodsFor: 'other'!
choosePartName
	"Override to add null on-ticks script when this morph is named."

	| newName |
	newName _ super choosePartName.
	newName ifNil: [^ self].  "user cancelled or chose a bad part name"
	(self world model class)
		compile: self buttonUpSelector
		classified: 'scripts'
		notifying: nil.
! !

!ButtonMorph methodsFor: 'other'!
choosePartNameSilently

	super choosePartNameSilently.
	(self world model class)
		compile: self buttonUpSelector
		classified: 'scripts'
		notifying: nil.
! !

!ButtonMorph methodsFor: 'other'!
doButtonAction

	self nameInModel ~~ nil ifTrue: [
		self world model perform: self buttonUpSelector].
! !

!ButtonMorph methodsFor: 'other' stamp: 'tk 12/4/97 11:22'!
lastAcceptedScript
	^ lastAcceptedScript! !

!ButtonMorph methodsFor: 'other' stamp: 'tk 9/21/97 00:16'!
lastAcceptedScript: scriptEditor
	"Need to do a clean store here."

	lastAcceptedScript _ scriptEditor! !

!ButtonMorph methodsFor: 'other' stamp: 'tk 9/21/97 00:16'!
lastScriptEditor: scriptEditor
	"Need to do a clean store here."

	lastScriptEditor _ scriptEditor! !
ArrayedCollection variableByteSubclass: #ByteArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!ByteArray commentStamp: 'di 5/22/1998 16:32' prior: 0!
ByteArray comment:
'I represent an ArrayedCollection whose elements can only be integers between 0 and 255. They are stored two bytes to a word.'!


!ByteArray methodsFor: 'accessing'!
asString
	"Convert to a String with Characters for each byte.
	Fast code uses primitive that avoids character conversion"

	^ (String new: self size) replaceFrom: 1 to: self size with: self! !

!ByteArray methodsFor: 'accessing'!
doubleWordAt: i 
	"Answer the value of the double word (4 bytes) starting at byte index i."

	| b0 b1 b2 w |
	"Primarily for reading socket #s in Pup headers"
	b0 _ self at: i.  
	b1 _ self at: i+1.  
	b2 _ self at: i+2.  
	w _ self at: i+3.
	"Following sequence minimizes LargeInteger arithmetic for small results."
	b2=0 ifFalse: [w _ (b2 bitShift: 8) + w].
	b1=0 ifFalse: [w _ (b1 bitShift: 16) + w].
	b0=0 ifFalse: [w _ (b0 bitShift: 24) + w].
	^w! !

!ByteArray methodsFor: 'accessing'!
doubleWordAt: i put: value 
	"Set the value of the double word (4 bytes) starting at byte index i."

	| w |
	"Primarily for setting socket #s in Pup headers"
	w _ value asInteger.
	self at: i put: (w digitAt: 4).
	self at: i + 1 put: (w digitAt: 3).
	self at: i + 2 put: (w digitAt: 2).
	self at: i + 3 put: (w digitAt: 1)! !

!ByteArray methodsFor: 'accessing'!
wordAt: i 
	"Answer the value of the word (2 bytes) starting at index i."

	| j |
	j _ i + i.
	^((self at: j - 1) bitShift: 8) + (self at: j)! !

!ByteArray methodsFor: 'accessing'!
wordAt: i put: v 
	"Set the value of the word (2 bytes) starting at index i."

	| j |
	j _ i + i.
	self at: j - 1 put: ((v bitShift: -8) bitAnd: 8r377).
	self at: j put: (v bitAnd: 8r377)! !


!ByteArray methodsFor: 'private'!
defaultElement

	^0! !

!ByteArray methodsFor: 'private'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !
Object subclass: #CCodeGenerator
	instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations methods variablesSetCache '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Squeak-Translation to C'!
!CCodeGenerator commentStamp: 'di 5/22/1998 16:32' prior: 0!
CCodeGenerator comment:
'This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.  Executing

	Interpreter translate: ''InterpTest.c'' doInlining: true.

(with single quotes) will cause all the methods of Interpreter, ObjectMemory and BitBltSimulation to be translated to C, and stored in the named file.  This file together with the files emitted by InterpreterSupportCode (qv) should be adequate to produce a complete interpreter for the Macintosh environment.'!


!CCodeGenerator methodsFor: 'public' stamp: 'ikp 12/4/97 23:01'!
addClass: aClass
	"Add the variables and methods of the given class to the code base."
	| source |
	self checkClassForNameConflicts: aClass.
	aClass classPool associationsDo: [ :assoc |
		constants at: assoc key put: (TConstantNode new setValue: assoc value).
	].
	"ikp..."
	aClass sharedPools do: [:pool |
		pool associationsDo: [ :assoc |
			constants at: assoc key put: (TConstantNode new setValue: assoc value).
		].
	].
	variables addAll: aClass instVarNames.
'Adding Class ' , aClass name , '...'
displayProgressAt: Sensor cursorPoint
from: 0 to: aClass selectors size
during: [:bar |
	aClass selectors doWithIndex: [ :sel :i | bar value: i.
		source _ aClass sourceCodeAt: sel.
		self addMethod: ((Compiler new parse: source in: aClass notifying: nil) asTMethodFromClass: aClass).
	]].! !

!CCodeGenerator methodsFor: 'public' stamp: 'jm 1/5/98 16:36'!
addClassVarsFor: aClass
	"Add the class variables for the given class (and its superclasses) to the code base as constants."

	| allClasses |
	allClasses _ aClass allSuperclasses asOrderedCollection.
	allClasses add: aClass.
	allClasses do: [:c |
		c classPool associationsDo:
			[:assoc | constants at: assoc key put: (TConstantNode new setValue: assoc value)]].
! !

!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:48'!
codeString
	"Return a string containing all the C code for the code base. Used for testing."

	| stream |
	stream _ ReadWriteStream on: (String new: 1000).
	self emitCCodeOn: stream doInlining: true doAssertions: true.
	^stream contents! !

!CCodeGenerator methodsFor: 'public' stamp: 'jm 2/15/98 18:26'!
codeStringForPrimitives: classAndSelectorList

	| sel aClass source s verbose meth |
	self initialize.
	classAndSelectorList do: [:classAndSelector |
		aClass _ Smalltalk at: (classAndSelector at: 1).
		self addClassVarsFor: aClass.
		sel _ classAndSelector at: 2.
		(aClass includesSelector: sel)
			ifTrue: [source _ aClass sourceCodeAt: sel]
			ifFalse: [source _ aClass class sourceCodeAt: sel].
		meth _ ((Compiler new parse: source in: aClass notifying: nil)
				asTMethodFromClass: aClass).
		meth primitive > 0 ifTrue: [meth preparePrimitiveInClass: aClass].
		"for old-style array accessing:
			meth covertToZeroBasedArrayReferences."
		meth replaceSizeMessages.
		self addMethod: meth].

	"method preparation"
	verbose _ false.
	self prepareMethods.
	verbose ifTrue: [
		self printUnboundCallWarnings.
		self printUnboundVariableReferenceWarnings.
		Transcript cr].

	"code generation"
	self doInlining: true.
	s _ ReadWriteStream on: (String new: 1000).
	methods _ methods asSortedCollection: [:m1 :m2 | m1 selector < m2 selector].
	self emitCHeaderForPrimitivesOn: s.
	self emitCVariablesOn: s.
	self emitCFunctionPrototypesOn: s.
	methods do: [:m | m emitCCodeOn: s generator: self].
	^ s contents
! !

!CCodeGenerator methodsFor: 'public'!
globalsAsSet
	"Used by the inliner to avoid name clashes with global variables."

	((variablesSetCache == nil) or:
	 [variablesSetCache size ~= variables size]) ifTrue: [
		variablesSetCache _ variables asSet.
	].
	^ variablesSetCache! !

!CCodeGenerator methodsFor: 'public'!
initialize

	translationDict _ Dictionary new.
	inlineList _ Array new.
	constants _ Dictionary new.
	variables _ OrderedCollection new.
	variableDeclarations _ Dictionary new.
	methods _ Dictionary new.
	self initializeCTranslationDictionary.! !

!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:50'!
storeCodeOnFile: fileName doInlining: inlineFlag
	"Store C code for this code base on the given file."

	self storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: true! !

!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:50'!
storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: assertionFlag
	"Store C code for this code base on the given file."

	| stream |
	stream _ FileStream newFileNamed: fileName.
	self emitCCodeOn: stream doInlining: inlineFlag doAssertions: assertionFlag.
	stream close.! !

!CCodeGenerator methodsFor: 'public'!
var: varName declareC: declarationString
	"Record the given C declaration for a global variable."

	variableDeclarations at: varName put: declarationString.! !


!CCodeGenerator methodsFor: 'error notification' stamp: 'ikp 12/4/97 22:56'!
checkClassForNameConflicts: aClass
	"Verify that the given class does not have constant, variable, or method names that conflict with those of previously added classes. Raise an error if a conflict is found, otherwise just return."

	"check for constant name collisions"
	aClass classPool associationsDo: [ :assoc |
		(constants includesKey: assoc key) ifTrue: [
			self error: 'Constant was defined in a previously added class: ', assoc key.
		].
	].
	"ikp..."
	aClass sharedPools do: [:pool |
		pool associationsDo: [ :assoc |
			(constants includesKey: assoc key) ifTrue: [
				self error: 'Constant was defined in a previously added class: ', assoc key.
			].
		].
	].

	"check for instance variable name collisions"
	aClass instVarNames do: [ :varName |
		(variables includes: varName) ifTrue: [
			self error: 'Instance variable was defined in a previously added class: ', varName.
		].
	].

	"check for method name collisions"
	aClass selectors do: [ :sel |
		(methods includesKey: sel) ifTrue: [
			self error: 'Method was defined in a previously added class: ', sel.
		].
	].! !

!CCodeGenerator methodsFor: 'error notification'!
printUnboundCallWarnings
	"Print a warning message for every unbound method call in the code base."

	| knownSelectors undefinedCalls |
	undefinedCalls _ Dictionary new.
	knownSelectors _ translationDict keys asSet.
	knownSelectors add: #error:.
	methods do: [ :m | knownSelectors add: m selector ].
	methods do: [ :m |
		m allCalls do: [ :sel |
			(knownSelectors includes: sel) ifFalse: [
				(undefinedCalls includesKey: sel)
					ifTrue: [ (undefinedCalls at: sel) add: m selector ]
					ifFalse: [ undefinedCalls at: sel put: (OrderedCollection with: m selector) ].
			].
		].
	].

	Transcript cr.
	undefinedCalls keys asSortedCollection do: [ :undefined |
		Transcript show: undefined, ' -- undefined method sent by:'; cr.
		(undefinedCalls at: undefined) do: [ :caller |
			Transcript tab; show: caller; cr.
		].
	].! !

!CCodeGenerator methodsFor: 'error notification'!
printUnboundVariableReferenceWarnings
	"Print a warning message for every unbound variable reference in the code base."

	| undefinedRefs globalVars knownVars |
	undefinedRefs _ Dictionary new.
	globalVars _ Set new: 100.
	globalVars addAll: variables.
	methods do: [ :m |
		knownVars _ globalVars copy.
		m args do: [ :var | knownVars add: var ].
		m locals do: [ :var | knownVars add: var ].
		m freeVariableReferences do: [ :varName |
			(knownVars includes: varName) ifFalse: [
				(undefinedRefs includesKey: varName)
					ifTrue: [ (undefinedRefs at: varName) add: m selector ]
					ifFalse: [ undefinedRefs at: varName put: (OrderedCollection with: m selector) ].
			].
		].
	].

	Transcript cr.
	undefinedRefs keys asSortedCollection do: [ :var |
		Transcript show: var, ' -- undefined variable used in:'; cr.
		(undefinedRefs at: var) do: [ :sel |
			Transcript tab; show: sel; cr.
		].
	].! !


!CCodeGenerator methodsFor: 'inlining'!
collectInlineList
	"Make a list of methods that should be inlined."
	"Details: The method must not include any inline C, since the translator cannot currently map variable names in inlined C code. Methods to be inlined must be small or called from only one place."

	| methodsNotToInline callsOf inlineIt hasCCode nodeCount senderCount |
	methodsNotToInline _ Set new: methods size.

	"build dictionary to record the number of calls to each method"
	callsOf _ Dictionary new: methods size * 2.
	methods keys do: [ :sel | callsOf at: sel put: 0 ].

	"For each method, scan its parse tree once to:
		1. determine if the method contains C code or declarations
		2. determine how many nodes it has
		3. increment the sender counts of the methods it calls
		4. determine if it includes any C declarations or code"
	inlineList _ Set new: methods size * 2.
	methods do: [ :m |
		inlineIt _ #dontCare.
		(translationDict includesKey: m selector) ifTrue: [
			hasCCode _ true.
		] ifFalse: [
			hasCCode _ m declarations size > 0.
			nodeCount _ 0.
			m parseTree nodesDo: [ :node |
				node isSend ifTrue: [
					sel _ node selector.
					sel = #cCode: ifTrue: [ hasCCode _ true ].
					senderCount _ callsOf at: sel ifAbsent: [ nil ].
					nil = senderCount ifFalse: [
						callsOf at: sel put: senderCount + 1.
					].
				].
				nodeCount _ nodeCount + 1.
			].
			inlineIt _ m extractInlineDirective.  "may be true, false, or #dontCare"
		].
		(hasCCode or: [inlineIt = false]) ifTrue: [
			"don't inline if method has C code and is contains negative inline directive"
			methodsNotToInline add: m selector.
		] ifFalse: [
			((nodeCount < 40) or: [inlineIt = true]) ifTrue: [
				"inline if method has no C code and is either small or contains inline directive"
				inlineList add: m selector.
			].
		].
	].

	callsOf associationsDo: [ :assoc |
		((assoc value = 1) and: [(methodsNotToInline includes: assoc key) not]) ifTrue: [
			inlineList add: assoc key.
		].
	].! !

!CCodeGenerator methodsFor: 'inlining'!
doInlining
	"Inline the bodies of all methods that are suitable for inlining."
	"Interpreter translate: 'InterpTest.c' doInlining: true"

	| pass progress |
	self collectInlineList.
	"xxx do we need the following?"
	Interpreter primitiveTable do: [ :sel |
		inlineList remove: sel ifAbsent: [].
	].

	pass _ 0.
	progress _ true.
	[progress] whileTrue: [
		"repeatedly attempt to inline methods until no further progress is made"
		progress _ false.
		('Inlining pass ', (pass _ pass + 1) printString, '...')
			displayProgressAt: Sensor cursorPoint
			from: 0 to: methods size
			during: [ :bar |
				methods doWithIndex: [ :m :i |
					bar value: i.
					(m tryToInlineMethodsIn: self)
						ifTrue: [progress _ true]]].
	].
	'Inlining bytecodes'
		displayProgressAt: Sensor cursorPoint
		from: 1 to: 2
		during: [ :bar |
			self inlineDispatchesInMethodNamed: #interpret
				localizingVars: #(currentBytecode localIP localSP).
			bar value: 1.
			self removeMethodsReferingToGlobals: #(currentBytecode localIP localSP)
				except: #interpret.
			bar value: 2.
	].
! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'ikp 1/3/98 23:13'!
doInlining: inlineFlag
	"Inline the bodies of all methods that are suitable for inlining."
	"Modified slightly for the translator, since the first level of inlining for the interpret
	loop must be performed in order that the instruction implementations can easily
	discover their addresses."

	"Interpreter translate: 'InterpTest.c' doInlining: true"

	| pass progress |

	inlineFlag ifFalse: [
		^self inlineDispatchesInMethodNamed: #interpret localizingVars: #().
	].

	self collectInlineList.
	"xxx do we need the following?"
	Interpreter primitiveTable do: [ :sel |
		inlineList remove: sel ifAbsent: [].
	].

	pass _ 0.
	progress _ true.
	[progress] whileTrue: [
		"repeatedly attempt to inline methods until no further progress is made"
		progress _ false.
		('Inlining pass ', (pass _ pass + 1) printString, '...')
			displayProgressAt: Sensor cursorPoint
			from: 0 to: methods size
			during: [ :bar |
				methods doWithIndex: [ :m :i |
					bar value: i.
					(m tryToInlineMethodsIn: self)
						ifTrue: [progress _ true]]].
	].
	'Inlining bytecodes'
		displayProgressAt: Sensor cursorPoint
		from: 1 to: 3
		during: [ :bar |
			self inlineDispatchesInMethodNamed: #interpret
				localizingVars: #(currentBytecode localIP localSP localCP localTP).
			bar value: 1.
"xxx
			(methods includesKey: #translateNewMethod) ifTrue:
				[self inlineDispatchesInMethodNamed: #translateNewMethod
					localizingVars: #(currentByte bytePointer opPointer).
				self removeMethodsReferingToGlobals: #(currentByte bytePointer opPointer)
					except: #translateNewMethod.
				].
xxx"
			bar value: 2.
			self removeMethodsReferingToGlobals: #(currentBytecode localIP localSP localCP localTP)
				except: #interpret.
			bar value: 3.
	].
! !

!CCodeGenerator methodsFor: 'inlining'!
inlineDispatchesInMethodNamed: selector localizingVars: varsList
	"Inline dispatches (case statements) in the method with the given name."

	| m |
	m _ self methodNamed: selector.
	m = nil ifFalse: [
		m inlineCaseStatementBranchesIn: self localizingVars: varsList.
		m parseTree nodesDo: [ :n |
			n isCaseStmt ifTrue: [
				n customizeShortCasesForDispatchVar: #currentBytecode.
			].
		].
	].
	variables _ variables asOrderedCollection.
	varsList do: [ :v |
		variables remove: v asString ifAbsent: [].
		(variableDeclarations includesKey: v asString) ifTrue: [
			m declarations at: v asString put: (variableDeclarations at: v asString).
			variableDeclarations removeKey: v asString.
		].
	].
! !

!CCodeGenerator methodsFor: 'inlining'!
mayInline: sel
	"Answer true if the method with the given selector may be inlined."

	^ inlineList includes: sel! !

!CCodeGenerator methodsFor: 'inlining'!
methodStatsString
	"Return a string describing the size, # of locals, and # of senders of each method. Note methods that have inline C code or C declarations."

	| methodsWithCCode sizesOf callsOf hasCCode nodeCount senderCount s calls registers selr |
	methodsWithCCode _ Set new: methods size.
	sizesOf _ Dictionary new: methods size * 2.  "selector -> nodeCount"
	callsOf _ Dictionary new: methods size * 2.  "selector -> senderCount"

	"For each method, scan its parse tree once to:
		1. determine if the method contains C code or declarations
		2. determine how many nodes it has
		3. increment the sender counts of the methods it calls
		4. determine if it includes any C declarations or code"

	methods do: [ :m |
		(translationDict includesKey: m selector) ifTrue: [
			hasCCode _ true.
		] ifFalse: [
			hasCCode _ m declarations size > 0.
			nodeCount _ 0.
			m parseTree nodesDo: [ :node |
				node isSend ifTrue: [
					selr _ node selector.
					selr = #cCode: ifTrue: [ hasCCode _ true ].
					senderCount _ callsOf at: selr ifAbsent: [ 0 ].
					callsOf at: selr put: senderCount + 1.
				].
				nodeCount _ nodeCount + 1.
			].
		].
		hasCCode ifTrue: [ methodsWithCCode add: m selector ].
		sizesOf at: m selector put: nodeCount.
	].

	s _ WriteStream on: (String new: 5000).
	methods keys asSortedCollection do: [ :sel |
		m _ methods at: sel.
		registers _ m locals size + m args size.
		calls _ callsOf at: sel ifAbsent: [0].
		registers > 11 ifTrue: [
			s nextPutAll: sel; tab.
			s nextPutAll: (sizesOf at: sel) printString; tab.
			s nextPutAll: calls printString; tab.
			s nextPutAll: registers printString; tab.
			(methodsWithCCode includes: sel) ifTrue: [ s nextPutAll: 'CCode' ].
		s cr.
		].
	].
	^ s contents! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	"Remove all assertions in method bodies.  This is for the benefit of inlining, which
	fails to recognise and disregard empty method bodies when checking the inlinability
	of sends."

	| newMethods |
	newMethods _ Dictionary new.
	'Removing assertions...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: methods size
		during: [ :bar |
			methods doWithIndex: [ :m :i |
				bar value: i.
				m isAssertion ifFalse: [
					newMethods at: m selector put: m.
					m removeAssertions]]].
	methods _ newMethods.! !

!CCodeGenerator methodsFor: 'inlining'!
removeMethodsReferingToGlobals: varList except: methodName
	"Remove any methods (presumably inlined) that still contain references to the given obsolete global variables."

	| varListAsStrings removeIt mVars |
	varListAsStrings _ varList collect: [ :sym | sym asString ].
	methods keys copy do: [ :sel |
		removeIt _ false.
		mVars _ (self methodNamed: sel) freeVariableReferences asSet.
		varListAsStrings do: [ :v |
			(mVars includes: v) ifTrue: [ removeIt _ true ].
		].
		(removeIt and: [sel ~= methodName]) ifTrue: [
			methods removeKey: sel ifAbsent: [].
		].
	].! !


!CCodeGenerator methodsFor: 'utilities'!
addMethod: aTMethod
	"Add the given method to the code base."

	(methods includesKey:  aTMethod selector) ifTrue: [
		self error: 'Method name conflict: ', aTMethod selector.
	].
	methods at: aTMethod selector put: aTMethod.! !

!CCodeGenerator methodsFor: 'utilities'!
builtin: sel
	"Answer true if the given selector is one of the builtin selectors."

	((sel = #longAt:) or: [(sel = #longAt:put:) or: [sel = #error:]]) ifTrue: [ ^true ].
	((sel = #byteAt:) or: [sel = #byteAt:put:]) ifTrue: [ ^true ].
	^translationDict includesKey: sel! !

!CCodeGenerator methodsFor: 'utilities'!
cCodeForMethod: selector
	"Answer a string containing the C code for the given method."
	"Example:
		((CCodeGenerator new initialize addClass: TestCClass1; prepareMethods)
			cCodeForMethod: #ifTests)"

	| m s |
	m _ self methodNamed: selector.
	m = nil ifTrue: [ self error: 'method not found in code base: ', selector ].

	s _ (ReadWriteStream on: '').
	m emitCCodeOn: s generator: self.
	^ s contents! !

!CCodeGenerator methodsFor: 'utilities'!
emitBuiltinConstructFor: msgNode on: aStream level: level
	"If the given selector is in the translation dictionary, translate it into a target code construct and return true. Otherwise, do nothing and return false."

	| action |
	action _ translationDict at: msgNode selector ifAbsent: [ ^false ].
	self perform: action with: msgNode with: aStream with: level.
	^true! !

!CCodeGenerator methodsFor: 'utilities'!
methodNamed: selector
	"Answer the method in the code base with the given selector."

	^ methods at: selector ifAbsent: [ nil ]! !

!CCodeGenerator methodsFor: 'utilities'!
methodsReferringToGlobal: v
	"Return a collection of methods that refer to the given global variable."

	| out |
	out _ OrderedCollection new.
	methods associationsDo: [ :assoc |
		(assoc value freeVariableReferences includes: v) ifTrue: [
			out add: assoc key.
		].
	].
	^ out! !

!CCodeGenerator methodsFor: 'utilities'!
methodsThatCanInvoke: aSelectorList
	"Return a set of methods that can invoke one of the given selectors, either directly or via a sequence of intermediate methods."

	| out todo sel mSelector |
	out _ Set new.
	todo _ aSelectorList copy asOrderedCollection.
	[todo isEmpty] whileFalse: [
		sel _ todo removeFirst.
		out add: sel.
		methods do: [ :m |
			(m allCalls includes: sel) ifTrue: [
				mSelector _ m selector.
				((out includes: mSelector) or:
				 [todo includes: mSelector]) ifFalse: [
					todo add: mSelector.
				].
			].
		].
	].
	^ out
	! !

!CCodeGenerator methodsFor: 'utilities'!
prepareMethods
	"Prepare methods for browsing."

	| globals |
	globals _ Set new: 200.
	globals addAll: variables.
	methods do: [ :m |
		(m locals, m args) do: [ :var |
			(globals includes: var) ifTrue: [
				self error: 'Local variable name may mask global when inlining: ', var.
			].
			(methods includesKey: var) ifTrue: [
				self error: 'Local variable name may mask method when inlining: ', var.
			].	
		].
		m bindClassVariablesIn: constants.
		m prepareMethodIn: self.
	].! !

!CCodeGenerator methodsFor: 'utilities'!
reportRecursiveMethods
	"Report in transcript all methods that can call themselves directly or indirectly or via a chain of N intermediate methods."

	| visited calls newCalls sel called |
	methods do: [: m |
		visited _ translationDict keys asSet.
		calls _ m allCalls asOrderedCollection.
		5 timesRepeat: [
			newCalls _ Set new: 50.
			[calls isEmpty] whileFalse: [
				sel _ calls removeFirst.
				sel = m selector ifTrue: [
					Transcript show: m selector, ' is recursive'; cr.
				] ifFalse: [
					(visited includes: sel) ifFalse: [
						called _ self methodNamed: sel.
						called = nil ifFalse: [ newCalls addAll: called allCalls ].
					].
					visited add: sel.
				].
			].
			calls _ newCalls asOrderedCollection.
		].
	].! !

!CCodeGenerator methodsFor: 'utilities'!
unreachableMethods
	"Return a collection of methods that are never invoked."

	| sent out |
	sent _ Set new.
	methods do: [ :m |
		sent addAll: m allCalls.
	].

	out _ OrderedCollection new.
	methods keys do: [ :sel |
		(sent includes: sel) ifFalse: [ out add: sel ].
	].
	^ out! !


!CCodeGenerator methodsFor: 'C code generator'!
cFunctionNameFor: aSelector
	"Create a C function name from the given selector by omitting colons."

	^aSelector copyWithout: $:! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 12/2/97 19:40'!
cLiteralFor: anObject
	"Return a string representing the C literal value for the given object."
	| s |
	(anObject isKindOf: Integer) ifTrue: [
		(anObject < 16r7FFFFFFF)
			ifTrue: [^ anObject printString]
			ifFalse: [^ anObject printString , 'U']].
	(anObject isKindOf: String) ifTrue: [^ '"', anObject, '"' ].
	(anObject isKindOf: Float) ifTrue: [^ anObject printString ].
	anObject == nil ifTrue: [^ 'null' ].
	anObject == true ifTrue: [^ '1' ].			"ikp"
	anObject == false ifTrue: [^ '0' ].			"ikp"
	self error:								"ikp"
		'Warning: A Smalltalk literal could not be translated into a C constant: ', anObject printString.
	^'"XXX UNTRANSLATABLE CONSTANT XXX"'! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 12/7/97 20:54'!
emitCCodeOn: aStream doInlining: inlineFlag

	self emitCCodeOn: aStream doInlining: inlineFlag doAssertions: true! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 12/7/97 20:54'!
emitCCodeOn: aStream doInlining: inlineFlag doAssertions: assertionFlag
	"Emit C code for all methods in the code base onto the given stream. All inlined method calls should already have been expanded."

	| verbose |
	"method preparation"
	verbose _ false.
	self prepareMethods.
	verbose ifTrue: [
		self printUnboundCallWarnings.
		self printUnboundVariableReferenceWarnings.
		Transcript cr.
	].
	assertionFlag ifFalse: [ self removeAssertions ].
	self doInlining: inlineFlag.

	"code generation"
	methods _ methods asSortedCollection: [ :m1 :m2 | m1 selector < m2 selector ].
	self emitCHeaderOn: aStream.
	self emitCVariablesOn: aStream.
	self emitCFunctionPrototypesOn: aStream.
'Writing Translated Code...'
displayProgressAt: Sensor cursorPoint
from: 0 to: methods size
during: [:bar |
	methods doWithIndex: [ :m :i | bar value: i.
		m emitCCodeOn: aStream generator: self.
]].! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCExpression: aParseNode on: aStream
	"Emit C code for the expression described by the given parse node."

	aParseNode isLeaf ifTrue: [
		"omit parens"
		aParseNode emitCCodeOn: aStream level: 0 generator: self.
	] ifFalse: [
		aStream nextPut: $(.
		aParseNode emitCCodeOn: aStream level: 0 generator: self.
		aStream nextPut: $).
	].! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCFunctionPrototypesOn: aStream
	"Store prototype declarations for all non-inlined methods on the given stream."

	aStream nextPutAll: '/*** Function Prototypes ***/'; cr.
	methods do: [ :m |
		m emitCFunctionPrototype: aStream generator: self.
		aStream nextPutAll: ';'; cr.
	].! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 1/4/98 00:03'!
emitCHeaderForPrimitivesOn: aStream
	"Write a C file header for compiled primitives onto the given stream."

	aStream nextPutAll: '/* Automatically generated from Squeak on '.
	aStream nextPutAll: Time dateAndTimeNow printString.
	aStream nextPutAll: ' */'; cr; cr.

	aStream nextPutAll: '#include "sq.h"'; cr; cr.

	aStream nextPutAll: '
/* Memory Access Macros */
#define byteAt(i) (*((unsigned char *) (i)))
#define byteAtput(i, val) (*((unsigned char *) (i)) = val)
#define longAt(i) (*((int *) (i)))
#define longAtput(i, val) (*((int *) (i)) = val)

/*** Imported Functions/Variables ***/
extern int stackValue(int);
extern int successFlag;
'.
	aStream cr.! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'jm 2/1/98 15:35'!
emitCHeaderOn: aStream
	"Write a C file header onto the given stream."

	aStream nextPutAll: '/* Automatically generated from Squeak on '.
	aStream nextPutAll: Time dateAndTimeNow printString.
	aStream nextPutAll: ' */'; cr; cr.

	aStream nextPutAll: '#include "sq.h"'; cr.
	aStream nextPutAll: '#include "sqMachDep.h"  /* needed only by the JIT virtual machine */'; cr.

	aStream nextPutAll: '
/* memory access macros */
#define byteAt(i) (*((unsigned char *) (i)))
#define byteAtput(i, val) (*((unsigned char *) (i)) = val)
#define longAt(i) (*((int *) (i)))
#define longAtput(i, val) (*((int *) (i)) = val)

int printCallStack(void);
void error(char *s);
void error(char *s) {
	/* Print an error message and exit. */
	static int printingStack = false;

	printf("\n%s\n\n", s);
	if (!!printingStack) {
		/* flag prevents recursive error when trying to print a broken stack */
		printingStack = true;
		printCallStack();
	}
	exit(-1);
}
'.
	aStream cr.! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCTestBlock: aBlockNode on: aStream
	"Emit C code for the given block node to be used as a loop test."

	aBlockNode statements size > 1 ifTrue: [
		aBlockNode emitCCodeOn: aStream level: 0 generator: self.
	] ifFalse: [
		aBlockNode statements first emitCCodeOn: aStream level: 0 generator: self.
	].! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCVariablesOn: aStream
	"Store the global variable declarations on the given stream."

	aStream nextPutAll: '/*** Variables ***/'; cr.
	variables asSortedCollection do: [ :var |
		(variableDeclarations includesKey: var) ifTrue: [
			aStream nextPutAll: (variableDeclarations at: var), ';'; cr.
		] ifFalse: [
			"default variable declaration"
			aStream nextPutAll: 'int ', var, ';'; cr.
		].
	].
	aStream cr.! !


!CCodeGenerator methodsFor: 'C translation'!
generateAnd: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' && '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateAt: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '['.
	msgNode args first emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ']'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateAtPut: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '['.
	msgNode args first emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: '] = '.
	self emitCExpression: msgNode args last on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitAnd: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' & '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitInvert32: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '~'.
	self emitCExpression: msgNode receiver on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitOr: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' | '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitShift: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| arg rcvr |
	arg _ msgNode args first.
	rcvr _ msgNode receiver.
	arg isConstant ifTrue: [
		"bit shift amount is a constant"
		aStream nextPutAll: '((unsigned) '.
		self emitCExpression: rcvr on: aStream.
		arg value < 0 ifTrue: [
			aStream nextPutAll: ' >> ', arg value negated printString.
		] ifFalse: [
			aStream nextPutAll: ' << ', arg value printString.
		].
		aStream nextPutAll: ')'.
	] ifFalse: [
		"bit shift amount is an expression"
		aStream nextPutAll: '(('.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: ' < 0) ? ((unsigned) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' >> -'.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: ') : ((unsigned) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' << '.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: '))'.
	].! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitXor: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' ^ '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateCCoercion: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	aStream nextPutAll: msgNode args last value.
	aStream nextPutAll: ') '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ')'.

! !

!CCodeGenerator methodsFor: 'C translation'!
generateDivide: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' / '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' == '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateGreaterThan: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' > '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateGreaterThanOrEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' >= '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIfFalse: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."
	"Note: PP 2.3 compiler produces two arguments for ifFalse:, presumably
	 to help with inlining later. Taking the last agument should do the correct
	 thing even if your compiler is different."

	aStream nextPutAll: 'if (!!('.
	msgNode receiver emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ')) {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIfFalseIfTrue: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."
	"Note: PP 2.3 compiler reverses the argument blocks for ifFalse:ifTrue:,
       presumably to help with inlining later. That is, the first argument
       is the block to be evaluated if the condition is true."

	aStream nextPutAll: 'if ('.
	msgNode receiver emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ') {'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '} else {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIfTrue: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: 'if ('.
	msgNode receiver emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ') {'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIfTrueIfFalse: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: 'if ('.
	msgNode receiver emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ') {'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '} else {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateInlineCCode: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: msgNode args first value.! !

!CCodeGenerator methodsFor: 'C translation'!
generateInlineDirective: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '/* inline: '.
	aStream nextPutAll: msgNode args first name.
	aStream nextPutAll: ' */'.
! !

!CCodeGenerator methodsFor: 'C translation'!
generateIntegerObjectOf: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' << 1) | 1)'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIntegerValueOf: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '('.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' >> 1)'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIsIntegerObject: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '('.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' & 1)'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIsNil: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' == '.
	aStream nextPutAll: (self cLiteralFor: nil).! !

!CCodeGenerator methodsFor: 'C translation'!
generateLessThan: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' < '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateLessThanOrEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' <= '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateMax: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' < '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ') ? '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' : '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateMin: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' < '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ') ? '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' : '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateMinus: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' - '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateModulo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' % '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateNot: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '!!'.
	self emitCExpression: msgNode receiver on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateNotEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' !!= '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateNotNil: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' !!= '.
	aStream nextPutAll: (self cLiteralFor: nil).! !

!CCodeGenerator methodsFor: 'C translation'!
generateOr: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' || '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generatePlus: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' + '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generatePreDecrement: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| varNode |
	varNode _ msgNode receiver.
	varNode isVariable
		ifFalse: [ self error: 'preDecrement can only be applied to variables' ].
	aStream nextPutAll: '--'.
	aStream nextPutAll: varNode name.
! !

!CCodeGenerator methodsFor: 'C translation'!
generatePreIncrement: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| varNode |
	varNode _ msgNode receiver.
	varNode isVariable
		ifFalse: [ self error: 'preIncrement can only be applied to variables' ].
	aStream nextPutAll: '++'.
	aStream nextPutAll: varNode name.
! !

!CCodeGenerator methodsFor: 'C translation'!
generateSequentialAnd: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' && ('.
	self emitCTestBlock: msgNode args first on: aStream.
	aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateSequentialOr: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."
	"Note: PP 2.3 compiler produces two arguments for or:, presumably
	 to help with inlining later. Taking the last agument should do the correct
	 thing even if your compiler is different."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' || ('.
	self emitCTestBlock: msgNode args last on: aStream.
	aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateSharedCodeDirective: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '/* common code: '.
	aStream nextPutAll: msgNode args first value.
	aStream nextPutAll: ' */'.
! !

!CCodeGenerator methodsFor: 'C translation'!
generateShiftLeft: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' << '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateShiftRight: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '((unsigned) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ')'.
	aStream nextPutAll: ' >> '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateTimes: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' * '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateToByDo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| iterationVar |
	(msgNode args last args size = 1) ifFalse: [
		self error: 'wrong number of block arguments'.
	].
	iterationVar _ msgNode args last args first.
	aStream nextPutAll: 'for (', iterationVar, ' = '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '; ', iterationVar, ' <= '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: '; ', iterationVar, ' += '.
	self emitCExpression: (msgNode args at: 2) on: aStream.
	aStream nextPutAll: ') {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateToDo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| iterationVar |
	(msgNode args last args size = 1) ifFalse: [
		self error: 'wrong number of block arguments'.
	].
	iterationVar _ msgNode args last args first.
	aStream nextPutAll: 'for (', iterationVar, ' = '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '; ', iterationVar, ' <= '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: '; ', iterationVar, '++) {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateWhileFalse: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: 'while (!!('.
	self emitCTestBlock: msgNode receiver on: aStream.
	aStream nextPutAll: ')) {'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateWhileTrue: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: 'while ('.
	self emitCTestBlock: msgNode receiver on: aStream.
	aStream nextPutAll: ') {'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'jm 2/15/98 17:07'!
initializeCTranslationDictionary 
	"Initialize the dictionary mapping message names to actions for C code generation."

	| pairs |
	translationDict _ Dictionary new: 200.
	pairs _ #(
	#&				#generateAnd:on:indent:
	#|				#generateOr:on:indent:
	#and:			#generateSequentialAnd:on:indent:
	#or:			#generateSequentialOr:on:indent:
	#not			#generateNot:on:indent:

	#+				#generatePlus:on:indent:
	#-				#generateMinus:on:indent:
	#*				#generateTimes:on:indent:
	#//				#generateDivide:on:indent:
	#\\				#generateModulo:on:indent:
	#<<				#generateShiftLeft:on:indent:
	#>>				#generateShiftRight:on:indent:
	#min:			#generateMin:on:indent:
	#max:			#generateMax:on:indent:

	#bitAnd:		#generateBitAnd:on:indent:
	#bitOr:			#generateBitOr:on:indent:
	#bitXor:			#generateBitXor:on:indent:
	#bitShift:		#generateBitShift:on:indent:
	#bitInvert32	#generateBitInvert32:on:indent:

	#<				#generateLessThan:on:indent:
	#<=				#generateLessThanOrEqual:on:indent:
	#=				#generateEqual:on:indent:
	#>				#generateGreaterThan:on:indent:
	#>=				#generateGreaterThanOrEqual:on:indent:
	#~=				#generateNotEqual:on:indent:
	#==				#generateEqual:on:indent:
	#isNil			#generateIsNil:on:indent:
	#notNil			#generateNotNil:on:indent:

	#whileTrue: 	#generateWhileTrue:on:indent:
	#whileFalse:	#generateWhileFalse:on:indent:
	#to:do:			#generateToDo:on:indent:
	#to:by:do:		#generateToByDo:on:indent:

	#ifTrue:		#generateIfTrue:on:indent:
	#ifFalse:		#generateIfFalse:on:indent:
	#ifTrue:ifFalse:	#generateIfTrueIfFalse:on:indent:
	#ifFalse:ifTrue:	#generateIfFalseIfTrue:on:indent:

	#at:				#generateAt:on:indent:
	#at:put:			#generateAtPut:on:indent:
	#basicAt:		#generateAt:on:indent:
	#basicAt:put:	#generateAtPut:on:indent:

	#integerValueOf:	#generateIntegerValueOf:on:indent:
	#integerObjectOf:	#generateIntegerObjectOf:on:indent:
	#isIntegerObject: 	#generateIsIntegerObject:on:indent:
	#cCode:				#generateInlineCCode:on:indent:
	#cCoerce:to:			#generateCCoercion:on:indent:
	#preIncrement		#generatePreIncrement:on:indent:
	#preDecrement		#generatePreDecrement:on:indent:
	#inline:				#generateInlineDirective:on:indent:
	#sharedCodeNamed:inCase:	#generateSharedCodeDirective:on:indent:
	).

	1 to: pairs size by: 2 do: [ :i |
		translationDict at: (pairs at: i) put: (pairs at: i + 1).
	].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CCodeGenerator class
	instanceVariableNames: ''!

!CCodeGenerator class methodsFor: 'removing from system' stamp: 'jm 5/16/1998 10:26'!
removeCompilerMethods
	"Before removing the C code generator classes from the system, use this method to remove the compiler node methods that support it. This avoids leaving dangling references to C code generator classes in the compiler node classes."

	ParseNode withAllSubclasses do: [ :nodeClass |
		nodeClass removeCategory: 'C translation'.
	].
	Smalltalk at: #AbstractSound ifPresent: [:abstractSound |
		 abstractSound class removeCategory: 'primitive generation'].
! !
SwikiAction subclass: #CachedSwikiAction
	instanceVariableNames: 'cacheDirectory cacheURL pwsURL '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PluggableWebServer'!
!CachedSwikiAction commentStamp: 'di 5/22/1998 16:32' prior: 0!
CachedSwikiAction caches SwikiAction pages so that they can be served as plain HTML files (no embedded Squeak code) even by a native webServer. 

You must edit three class methods in CachedSwikiAction to get it to serve appropriately.

* CachedSwikiAction class defaultCacheDirectory is where to store cached pages
* CachedSwikiAction class defaultCacheURL is the URL to precede cached pages
* CachedSwikiAction class defaultPWSURL is where the PWS is that can handle editing and searching.

!
]style[(25 12 201 45 34 39 38 37 61)f1,f1LSwikiAction Comment;,f1,f1LCachedSwikiAction class defaultCacheDirectory;,f1,f1LCachedSwikiAction class defaultCacheURL;,f1,f1LCachedSwikiAction class defaultPWSURL;,f1!


!CachedSwikiAction methodsFor: 'save/restore' stamp: 'mjg 3/18/98 12:44'!
restore: nameOfSwiki
	super restore: nameOfSwiki.
	self source: 'cswiki',(ServerAction pathSeparator).
	self cacheDirectory: (self class defaultCacheDirectory).
	self cacheURL: (self class defaultCacheURL).
	self pwsURL: (self class defaultPWSURL).
	self generate.
! !

!CachedSwikiAction methodsFor: 'save/restore' stamp: 'mjg 3/23/98 11:35'!
restoreNoGen: nameOfSwiki
	super restore: nameOfSwiki.
	self source: 'cswiki',(ServerAction pathSeparator).
	self cacheDirectory: (self class defaultCacheDirectory).
	self cacheURL: (self class defaultCacheURL).
	self pwsURL: (self class defaultPWSURL).
	"self generate."
! !


!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:41'!
browse: pageRef from: request
	"Just reply with a page in HTML format"

	| formattedPage |
	formattedPage _ pageRef copy.
	"Make a copy, then format the text."
	formattedPage formatted: (HTMLformatter swikify: pageRef text
			linkhandler: [:link | urlmap
					linkForCache: link
					from: request peerName
					storingTo: OrderedCollection new]).
	request reply: (HTMLformatter evalEmbedded: (self fileContents: source ,'page.html')
			with: formattedPage).
! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:34'!
generate
	1 to: (urlmap pages size) do: [:ref |
		self generate: (urlmap atID: ref) from: 'Beginning'.].
	self generateRecent.
! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/26/98 12:39'!
generate: pageRef from: request
	"Just reply with a page in HTML format"

	| formattedPage peer cacheFile file|
	(request isKindOf: PWS) 
	ifFalse: [(request isKindOf: String) ifTrue: [peer _ request] ifFalse: [peer _ ' ']] 
	ifTrue: [peer _ request peerName].
	formattedPage _ pageRef copy.
	"Make a copy, then format the text."
	formattedPage formatted: (HTMLformatter swikify: pageRef text
			linkhandler: [:link | urlmap
					linkForCache: link
					from: peer
					storingTo: OrderedCollection new]).
	cacheFile _ (self cacheDirectory),(self name),(ServerAction pathSeparator),(pageRef coreID),'.html'.
	(StandardFileStream isAFileNamed: cacheFile)
	ifTrue: [FileDirectory deleteFilePath: cacheFile].
	file _ FileStream fileNamed: cacheFile.
	file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents: source ,'page.html')
			with: formattedPage).
	file close.

! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:21'!
generateRecent
	| file |
	file _ FileStream fileNamed: (self cacheDirectory),(self name),(ServerAction pathSeparator),'recent.html'.
	file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents: source, 'recent.html')
					with: urlmap recentCache).
	file close.! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/23/98 11:44'!
inputFrom: request
	"Take user's input and respond with a searchresult or store the edit"

	| coreRef page |
	coreRef _ request message size < 2
		ifTrue: ['1']
		ifFalse: [request message at: 2].
	coreRef = 'searchresult' ifTrue: [
		"If contains search string, do search"
		request reply: PWS crlf, 
			(HTMLformatter evalEmbedded: (self fileContents: source, 'results.html')
				with: (urlmap searchCacheFor: (request fields at: 'searchFor' ifAbsent: ['nothing']))).
		^ #return].
	(request fields includesKey: 'text') ifTrue: ["It's a response from an edit, so store the page"
		page _ urlmap
			storeID: coreRef
			text: (request fields at: 'text' ifAbsent: ['blank text'])
			from: request peerName.
		page user: request userID.  "Address is machine, user only if logged in"
		self generate: (urlmap atID: coreRef) from: request.
		self generateRecent.
		^ self].	"return self means do serve the edited page afterwards"
	"oops, a new kind!!"
	Transcript show: 'Unknown data from client. '; show: request fields printString; cr.! !


!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:39'!
cacheDirectory
	^cacheDirectory! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:39'!
cacheDirectory: directory
	cacheDirectory _ directory! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:44'!
cacheURL
	^cacheURL! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:44'!
cacheURL: urlString
	cacheURL _ urlString! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 12:44'!
pwsURL
	^pwsURL	! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 12:44'!
pwsURL: urlString
	pwsURL _ urlString	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CachedSwikiAction class
	instanceVariableNames: ''!

!CachedSwikiAction class methodsFor: 'initialization' stamp: 'tk 5/21/1998 12:58'!
setUp: named
	| newAction |
	super setUp: named.
	newAction _ PWS actions at: named.
	newAction cacheDirectory: (self defaultCacheDirectory).
	newAction cacheURL: (self defaultCacheURL).
	newAction source: 'cswiki',(ServerAction pathSeparator).
	^ newAction! !


!CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'!
defaultCacheDirectory
	^'Guz 7600:WebSTAR 2.0:'! !

!CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'!
defaultCacheURL
	^'http://guzdial.cc.gatech.edu/'! !

!CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'!
defaultPWSURL
	^'http://guzdial.cc.gatech.edu:8080/'! !
Morph subclass: #CachingMorph
	instanceVariableNames: 'damageRecorder cacheCanvas '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!CachingMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
CachingMorph comment:
'This morph can be used to cache the picture of a morph that takes a long time to draw. It should be used with judgement, however, since heavy use of caching can consume large amounts of memory.'!


!CachingMorph methodsFor: 'all'!
drawOn: aCanvas

	submorphs isEmpty ifTrue: [^ super drawOn: aCanvas].
! !

!CachingMorph methodsFor: 'all'!
fullDrawOn: aCanvas

	self updateCacheCanvasDepth: aCanvas depth.
	aCanvas image: cacheCanvas form at: self fullBounds origin.
! !

!CachingMorph methodsFor: 'all'!
imageForm

	self updateCacheCanvasDepth: Display depth.
	^ cacheCanvas form offset: self fullBounds topLeft
! !

!CachingMorph methodsFor: 'all'!
initialize

	super initialize.
	color _ Color veryLightGray.
	damageRecorder _ DamageRecorder new.
! !

!CachingMorph methodsFor: 'all'!
invalidRect: damageRect
	"Record the given rectangle in the damage list."

	damageRecorder recordInvalidRect: (damageRect translateBy: self fullBounds origin negated).
	super invalidRect: damageRect.
! !

!CachingMorph methodsFor: 'all' stamp: 'jm 11/13/97 16:31'!
releaseCachedState

	super releaseCachedState.
	cacheCanvas _ nil.
! !

!CachingMorph methodsFor: 'all' stamp: 'jm 7/30/97 12:43'!
updateCacheCanvasDepth: depth
	"Update the cached image of the morphs being held by this hand."

	| myBnds rectList c |
	myBnds _ self fullBounds.
	(cacheCanvas == nil or: [cacheCanvas extent ~= myBnds extent]) ifTrue: [
		cacheCanvas _ FormCanvas extent: myBnds extent depth: depth.
		c _ cacheCanvas copyOffset: myBnds origin negated.
		^ super fullDrawOn: c].

	"incrementally update the cache canvas"
	rectList _ damageRecorder invalidRectsFullBounds: (0@0 extent: myBnds extent).
	damageRecorder reset.
	rectList do: [:r |
		c _ cacheCanvas copyOrigin: myBnds origin negated clipRect: r.
		c fillColor: Color transparent.  "clear to transparent"
		super fullDrawOn: c].
! !
Object subclass: #Canvas
	instanceVariableNames: 'origin clipRect shadowDrawing '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!Canvas commentStamp: 'di 5/22/1998 16:32' prior: 0!
Canvas comment:
'A canvas is a two-dimensional medium on which morphs are drawn in a device-independent manner. Canvases keep track of the origin and clipping rectangle, as well as the underlying drawing medium (such as a window, pixmap, or postscript script).

This kind of canvas does no drawing, and may be used as a "null canvas" to factor out drawing time during performance measurements.'!


!Canvas methodsFor: 'initialization'!
reset

	origin _ 0@0.							"origin of the top-left corner of this cavas"
	clipRect _ (0@0 corner: 10000@10000).		"default clipping rectangle"
	shadowDrawing _ false.					"draw translucent shadows when true"! !


!Canvas methodsFor: 'copying' stamp: 'jm 8/2/97 13:54'!
copy

	^ self clone
! !

!Canvas methodsFor: 'copying'!
copyClipRect: aRectangle

	^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin)
! !

!Canvas methodsFor: 'copying'!
copyForShadowDrawingOffset: aPoint

	^ (self copyOrigin: origin + aPoint clipRect: clipRect) setShadowDrawing! !

!Canvas methodsFor: 'copying'!
copyOffset: aPoint

	^ self copyOrigin: origin + aPoint clipRect: clipRect! !

!Canvas methodsFor: 'copying'!
copyOffset: aPoint clipRect: sourceClip
	"Make a copy of me offset by aPoint, and further clipped
	by sourceClip, a rectangle in the un-offset coordinates"

	^ self copyOrigin: aPoint + origin
		clipRect: ((sourceClip translateBy: origin) intersect: clipRect)! !

!Canvas methodsFor: 'copying'!
copyOrigin: aPoint clipRect: aRectangle
	"Return a copy of this canvas with the given origin. The clipping rectangle of this canvas is the intersection of the given rectangle and the receiver's current clipping rectangle. This allows the clipping rectangles of nested clipping morphs to be composed."

	^ self copy
		setOrigin: aPoint
		clipRect: (clipRect intersect: aRectangle)! !


!Canvas methodsFor: 'accessing'!
clipRect
	^ clipRect translateBy: origin negated! !

!Canvas methodsFor: 'accessing'!
depth

	^ Display depth
! !

!Canvas methodsFor: 'accessing'!
origin

	^ origin! !


!Canvas methodsFor: 'testing'!
isVisible: aRectangle
	"Optimization of: ^ clipRect intersects: (aRectangle translateBy: origin)"

	^ ((aRectangle right + origin x) < clipRect left or:
	  [(aRectangle left + origin x) > clipRect right or:
	  [(aRectangle bottom + origin y) < clipRect top or:
	  [(aRectangle top + origin y) > clipRect bottom]]]) not
! !


!Canvas methodsFor: 'drawing'!
fillColor: c
	"Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
fillOval: r color: c

	self fillOval: r color: c borderWidth: 0 borderColor: Color transparent.
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Noop here; overridden by non-trivial canvases."
! !

!Canvas methodsFor: 'drawing'!
fillRectangle: r color: c
	"Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	"Noop here; overridden by non-trivial canvases."
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
	"Noop here; overridden by non-trivial canvases."
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 14:08'!
frameOval: r color: c

	self fillOval: r color: Color transparent borderWidth: 1 borderColor: c.
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 14:10'!
frameOval: r width: w color: c

	self fillOval: r color: Color transparent borderWidth: w borderColor: c.
! !

!Canvas methodsFor: 'drawing'!
frameRectangle: r color: c

	self frameRectangle: r width: 1 color: c.
! !

!Canvas methodsFor: 'drawing'!
frameRectangle: r width: w color: c
	"Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing'!
image: i at: aPoint
	"Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing' stamp: 'jm 7/28/97 14:30'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Noop here; overridden by non-trivial canvases."
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
line: pt1 to: pt2 color: c

	self line: pt1 to: pt2 width: 1 color: c.
! !

!Canvas methodsFor: 'drawing'!
line: pt1 to: pt2 width: w color: c
	"Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing'!
paragraph: paragraph bounds: bounds color: c
	"Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing'!
point: p color: c
	"Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
text: s at: pt font: fontOrNil color: c

	^ self text: s bounds: (pt extent: 10000@10000) font: fontOrNil color: c
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
text: s bounds: boundsRect font: fontOrNil color: c
	"Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used. Noop here; overridden by non-trivial canvases."
! !


!Canvas methodsFor: 'private'!
setOrigin: aPoint clipRect: aRectangle

	origin _ aPoint.
	clipRect _ aRectangle.
! !

!Canvas methodsFor: 'private'!
setShadowDrawing
	"Put this canvas into 'shadow drawing' mode, which is used to draw translucent shadows. While in this mode, all drawing operations are done in black through a gray mask. The mask allows some of the underlying pixels to show through, providing a crude sense of transparency."

	shadowDrawing _ true.! !
ParseNode subclass: #CascadeNode
	instanceVariableNames: 'receiver messages '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!CascadeNode commentStamp: 'di 5/22/1998 16:32' prior: 0!
CascadeNode comment: 'The first message has the common receiver, the rest have receiver == nil, which signifies cascading.'!


!CascadeNode methodsFor: 'initialize-release'!
receiver: receivingObject messages: msgs
	" Transcript show: 'abc'; cr; show: 'def' "

	receiver _ receivingObject.
	messages _ msgs! !


!CascadeNode methodsFor: 'code generation'!
emitForValue: stack on: aStream

	receiver emitForValue: stack on: aStream.
	1 to: messages size - 1 do: 
		[:i | 
		aStream nextPut: Dup.
		stack push: 1.
		(messages at: i) emitForValue: stack on: aStream.
		aStream nextPut: Pop.
		stack pop: 1].
	messages last emitForValue: stack on: aStream! !

!CascadeNode methodsFor: 'code generation'!
sizeForValue: encoder

	| size |
	size _ (receiver sizeForValue: encoder) + (messages size - 1 * 2).
	messages do: [:aMessage | size _ size + (aMessage sizeForValue: encoder)].
	^size! !


!CascadeNode methodsFor: 'printing'!
printOn: aStream indent: level
	self printOn: aStream indent: level precedence: 0! !

!CascadeNode methodsFor: 'printing'!
printOn: aStream indent: level precedence: p
	| thisPrec |
	p > 0 ifTrue: [aStream nextPut: $(].
	thisPrec _ messages first precedence.
	receiver printOn: aStream indent: level precedence: thisPrec.
	1 to: messages size do: 
		[:i | 
		(messages at: i) printOn: aStream indent: level.
		i < messages size
			ifTrue: [aStream nextPut: $;.
					thisPrec >= 2 ifTrue: [aStream crtab: level]]].
	p > 0 ifTrue: [aStream nextPut: $)]! !


!CascadeNode methodsFor: 'C translation'!
asTranslatorNode
	^TStmtListNode new
		setArguments: #()
		statements: (messages collect:
			[ :msg | msg asTranslatorNode receiver: receiver asTranslatorNode ])! !
Object subclass: #CautiousModel
	instanceVariableNames: 'initialExtent '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!CautiousModel methodsFor: 'all' stamp: 'sw 8/15/97 17:20'!
fullScreenSize
	"Answer the size to which a window displaying the receiver should be set"

	^ (0@0 extent: DisplayScreen actualScreenSize) copy! !

!CautiousModel methodsFor: 'all' stamp: 'sw 10/2/97 23:16'!
initialExtent
	initialExtent ifNotNil: [^ initialExtent].
	^ super initialExtent! !

!CautiousModel methodsFor: 'all' stamp: 'sw 10/2/97 23:16'!
initialExtent: anExtent
	initialExtent _ anExtent! !

!CautiousModel methodsFor: 'all' stamp: 'sw 10/2/97 16:19'!
okToChange
	| parms |
	(parms _ Smalltalk at: #EToyParameters ifAbsent: [nil]) ifNotNil:
		[parms cautionBeforeClosing ifFalse: [^ true]].
	Sensor leftShiftDown ifTrue: [^ true].

	self beep.
	^ self confirm: 'Warning!!
If you answer "yes" here, this
window will disappear and
its contents will be lost!!
Do you really want to do that?'

"CautiousModel new okToChange"! !
StringHolder subclass: #ChangeList
	instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Changes'!
!ChangeList commentStamp: 'di 5/22/1998 16:32' prior: 0!
A ChangeList represents a list of changed methods that reside on a file in fileOut format.  The classes and methods in my list are not necessarily in this image!!  Used as the model for both Version Lists and Changed Methods (in Screen Menu, Changes...).  Note that the two kinds of window have different controller classes!!!!

It holds three lists:
	changeList - a list of ChangeRecords
	list - a list of one-line printable headers
	listSelections - a list of Booleans (true = selected, false = not selected) multiple OK.
	listIndex 
Items that are removed (removeDoits, remove an item) are removed from all three lists.
Most recently clicked item is the one showing in the bottom pane.!


!ChangeList methodsFor: 'initialization-release'!
addItem: item text: text
	| cr |
	cr _ Character cr.
	changeList addLast: item.
	list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])! !


!ChangeList methodsFor: 'scanning' stamp: 'sw 1/15/98 21:56'!
scanCategory  
	"Scan anything that involves more than one chunk; method name is historical only"

	| itemPosition item tokens stamp isComment anIndex |
	itemPosition _ file position.
	item _ file nextChunk.

	isComment _ (item includesSubString: 'commentStamp:').
	(isComment or: [item includesSubString: 'methodsFor:']) ifFalse:
		["Maybe a preamble, but not one we recognize; bail out with the preamble trick"
		^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble)
				 text: ('preamble: ' , item contractTo: 50)].

	tokens _ Scanner new scanTokens: item.
	tokens size >= 3 ifTrue:
		[stamp _ ''.
		anIndex _ tokens indexOf: #stamp: ifAbsent: [nil].
		anIndex ifNotNil: [stamp _ tokens at: (anIndex + 1)].

		tokens second == #methodsFor:
			ifTrue: [^ self scanCategory: tokens third class: tokens first
							meta: false stamp: stamp].
		tokens third == #methodsFor:
			ifTrue: [^ self scanCategory: tokens fourth class: tokens first
							meta: true stamp: stamp]].

		tokens second == #commentStamp:
			ifTrue:
				[stamp _ tokens third.
				self addItem:
						(ChangeRecord new file: file position: file position type: #classComment
										class: tokens first category: nil meta: false stamp: stamp)
						text: 'class comment for ' , tokens first, 
							  (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]).
				file nextChunk.
				^ file skipStyleChunk]! !

!ChangeList methodsFor: 'scanning' stamp: 'di 1/13/98 16:56'!
scanCategory: category class: class meta: meta stamp: stamp
	| itemPosition method |
	[itemPosition _ file position.
	method _ file nextChunk.
	file skipStyleChunk.
	method size > 0]						"done when double terminators"
		whileTrue:
		[self addItem: (ChangeRecord new file: file position: itemPosition type: #method
							class: class category: category meta: meta stamp: stamp)
			text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' '])
				, (Parser new parseSelector: method)
				, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! !

!ChangeList methodsFor: 'scanning' stamp: 'di 1/13/98 16:57'!
scanFile: aFile from: startPosition to: stopPosition
	| itemPosition item prevChar |
	file _ aFile.
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	listIndex _ 0.
	file position: startPosition.
'Scanning changes...'
	displayProgressAt: Sensor cursorPoint
	from: startPosition to: stopPosition
	during: [:bar |
	[file position < stopPosition]
		whileTrue:
		[bar value: file position.
		[file atEnd not and: [file peek isSeparator]]
				whileTrue: [prevChar _ file next].
		(file peekFor: $!!)
		ifTrue:
			[prevChar = Character cr ifTrue: [self scanCategory]]
		ifFalse:
			[itemPosition _ file position.
			item _ file nextChunk.
			file skipStyleChunk.
			item size > 0 ifTrue:
				[self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt)
					text: 'do it: ' , (item contractTo: 50)]]]].
	listSelections _ Array new: list size withAll: false! !

!ChangeList methodsFor: 'scanning' stamp: 'di 5/17/1998 12:01'!
scanVersionsOf: method class: class meta: meta category: category selector: selector
	| position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp |
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	listIndex _ 0.
	position _ method filePosition.
	sourceFilesCopy _ SourceFiles collect:
		[:x | x isNil ifTrue: [ nil ]
				ifFalse: [x readOnlyCopy]].
	method fileIndex == 0 ifTrue: [self inform: 'Not Logged, no versions'.
								^ nil].
	file _ sourceFilesCopy at: method fileIndex.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  "Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].

		"Preamble is likely a linked method preamble, if we're in
			a changes file (not the sources file).  Try to parse it
			for prior source position and file index"
		prevPos _ nil.
		stamp _ ''.
		(preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [tokens _ Scanner new scanTokens: preamble]
			ifFalse: [tokens _ Array new  "ie cant be back ref"].
		((tokens size between: 7 and: 8)
			and: [(tokens at: tokens size-5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-3) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size-2.
						prevPos _ tokens last.
						prevFileIndex _ prevPos // 16r1000000.
						prevPos _ prevPos \\ 16r1000000]
				ifFalse: ["Old format gives no stamp; prior pointer in two parts"
						prevPos _ tokens at: tokens size-2.
						prevFileIndex _ tokens last].
				(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]].
		((tokens size between: 5 and: 6)
			and: [(tokens at: tokens size-3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-1) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size]].
 		self addItem:
				(ChangeRecord new file: file position: position type: #method
						class: class name category: category meta: meta stamp: stamp)
			text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector.
		position _ prevPos.
		prevPos notNil ifTrue:
			[file _ sourceFilesCopy at: prevFileIndex]].
	sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
	listSelections _ Array new: list size withAll: false! !

!ChangeList methodsFor: 'scanning' stamp: 'tk 4/24/1998 23:32'!
toggleListIndex: newListIndex

	(listIndex ~= 0 and: [listIndex ~= newListIndex]) ifTrue:
		[listSelections at: listIndex put: false].  "turn off old selection if was on"
	newListIndex = 0 
		ifTrue: [listIndex _ 0]
		ifFalse: [
			listSelections at: newListIndex  "Complement selection state"
					put: (listSelections at: newListIndex) not.
			listIndex _ (listSelections at: newListIndex)
				ifTrue: [newListIndex]  "and set selection index accordingly"
				ifFalse: [0]].
	self changed: #listIndex.
	self changed: #contents! !


!ChangeList methodsFor: 'menu actions' stamp: 'jm 5/3/1998 19:15'!
acceptFrom: aView

	aView controller text = aView controller initialText ifFalse: [
		aView flash.
		^ self inform: 'You can only accept this version as-is.
If you want to edit, copy the text to a browser'].
	(aView setText: aView controller text from: self) ifTrue:
		[aView ifNotNil: [aView controller accept]].	"initialText"
! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 4/6/98 11:33'!
changeListMenu: aMenu

^ aMenu labels:
'fileIn selections
fileOut selections...
select conflicts
select conflicts with
select unchanged methods
select all
deselect all
remove doIts
remove older versions
remove selections'
	lines: #(2 6)
	selections: #(fileInSelections fileOutSelections selectConflicts selectConflictsWith selectUnchangedMethods selectAll deselectAll removeDoIts removeOlderMethodVersions removeSelections)
! !

!ChangeList methodsFor: 'menu actions'!
deselectAll 
	listIndex _ 0.
	listSelections atAllPut: false.
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions'!
fileInSelections 
	listSelections with: changeList do: 
		[:selected :item | selected ifTrue: [item fileIn]]! !

!ChangeList methodsFor: 'menu actions' stamp: 'jm 6/12/97 10:54'!
fileOutSelections 
	| f |
	f _ FileStream newFileNamed: (FillInTheBlank request: 'Enter file name' initialAnswer: 'Filename.st').
	f header; timeStamp.
	listSelections with: changeList do: 
		[:selected :item | selected ifTrue: [item fileOutOn: f]].
	f close.
! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 4/21/1998 09:56'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If I can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 

	(#accept == selector) ifTrue: [^ self acceptFrom: otherTarget view].
	^ super perform: selector orSendTo: otherTarget! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 4/8/98 12:38'!
removeDoIts
	"Remove doits from the receiver, other than initializes. 1/26/96 sw"

	| newChangeList newList |

	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.

	changeList with: list do:
		[:chRec :str |
			(chRec type ~~ #doIt or:
				[str endsWith: 'initialize'])
					ifTrue:
						[newChangeList add: chRec.
						newList add: str]].
	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList.
			list _ newList.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list.

	! !

!ChangeList methodsFor: 'menu actions' stamp: 'di 6/13/97 23:10'!
removeOlderMethodVersions
	"Remove older versions of entries from the receiver."
	| newChangeList newList found str |
	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.
	found _ OrderedCollection new.

	changeList reverseWith: list do:
		[:chRec :strNstamp | str _ strNstamp copyUpTo: $;.
			(found includes: str)
				ifFalse:
					[found add: str.
					newChangeList add: chRec.
					newList add: strNstamp]].
	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList reversed.
			list _ newList reversed.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list! !

!ChangeList methodsFor: 'menu actions'!
removeSelections
	"Remove the selected items from the receiver.  9/18/96 sw"

	| newChangeList newList |

	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.

	1 to: changeList size do:
		[:i | (listSelections at: i) ifFalse:
			[newChangeList add: (changeList at: i).
			newList add: (list at: i)]].
	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList.
			list _ newList.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list

	! !

!ChangeList methodsFor: 'menu actions'!
selectAll
	listIndex _ 0.
	listSelections atAllPut: true.
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions'!
selectConflicts
	"Selects all method definitions for which there is ALSO an entry in changes"
	| change class systemChanges |
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class _ change methodClass) notNil
			and: [(Smalltalk changes atSelector: change methodSelector
						class: class) ~~ #none]])]].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions'!
selectConflicts: changeSetOrList
	"Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList"
	| change class systemChanges |
	Cursor read showWhile: 
	[(changeSetOrList isKindOf: ChangeSet) ifTrue: [
	1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class _ change methodClass) notNil
			and: [(changeSetOrList atSelector: change methodSelector
						class: class) ~~ #none]])]]
	ifFalse: ["a ChangeList"
	1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class _ change methodClass) notNil
			and: [changeSetOrList list includes: (list at: i)]])]]
	].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'jm 5/22/1998 11:31'!
selectConflictsWith
	"Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk"
	| aStream all index |
	aStream _ WriteStream on: (String new: 200).
	all _ ChangeSet allInstances asOrderedCollection.
	all do:
		[:sel | aStream nextPutAll: (sel name contractTo: 40); cr].
	ChangeList allInstancesDo:
		[:sel | aStream nextPutAll: (sel file name); cr.
			all addLast: sel].
	aStream skip: -1.
	index _ (PopUpMenu labels: aStream contents) startUp.
	index > 0 ifTrue: [
		self selectConflicts: (all at: index)].
! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 1/7/98 10:12'!
selectUnchangedMethods
	"Selects all method definitions for which there is already a method in the current image, whose source is exactly the same.  9/18/96 sw"
	| change class |
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			((change type = #method and:
				[(class _ change methodClass) notNil]) and:
					[(class includesSelector: change methodSelector) and:
						[change string = (class sourceCodeAt: change methodSelector) asString]])]].
	self changed: #allSelections! !


!ChangeList methodsFor: 'viewing access' stamp: 'sw 1/15/98 22:45'!
contents
	^ listIndex = 0
		ifTrue: ['']
		ifFalse: [(changeList at: listIndex) text]! !

!ChangeList methodsFor: 'viewing access' stamp: 'tk 4/10/1998 09:25'!
contents: aString
	listIndex = 0 ifTrue: [self changed: #flash. ^ false].
	lostMethodPointer ifNotNil: [^ self restoreDeletedMethod].
	self okToChange "means not dirty" ifFalse: ["is dirty"
		self inform: 'This is a view of a method on a file.\Please cancel your changes.  You may\accept, but only when the method is untouched.' withCRs.  ^ false].
		"Can't accept changes here.  Method text must be unchanged!!"
	(changeList at: listIndex) fileIn.
	^ true! !

!ChangeList methodsFor: 'viewing access'!
defaultBackgroundColor
	^ #lightBlue! !

!ChangeList methodsFor: 'viewing access'!
list
	^ list! !

!ChangeList methodsFor: 'viewing access'!
listIndex
	^ listIndex! !

!ChangeList methodsFor: 'viewing access'!
listSelectionAt: index
	^ listSelections at: index! !

!ChangeList methodsFor: 'viewing access'!
listSelectionAt: index put: value
	listIndex _ 0.
	^ listSelections at: index put: value! !

!ChangeList methodsFor: 'viewing access' stamp: 'di 6/15/97 16:46'!
restoreDeletedMethod
	"If lostMethodPointer is not nil, then this is a version browser for a method that has been removed.  In this case we want to establish a sourceCode link to prior versions.  We do this by installing a dummy method with the correct source code pointer prior to installing this version."
	| dummyMethod class selector |
	dummyMethod _ CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer.
	class _ (changeList at: listIndex) methodClass.
	selector _ (changeList at: listIndex) methodSelector.
	class addSelector: selector withMethod: dummyMethod.
	(changeList at: listIndex) fileIn.
	"IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails."
	(class compiledMethodAt: selector) == dummyMethod
		ifTrue: [class removeSelectorSimply: selector].
	^ true! !

!ChangeList methodsFor: 'viewing access' stamp: 'tk 4/18/1998 09:46'!
selectedMessageName

	^ (changeList at: listIndex) methodSelector

"
change _ changeList at: i.
			((change type = #method and:
				[(class _ change methodClass) notNil]) and:
					[(class includesSelector: change methodSelector
"! !


!ChangeList methodsFor: 'accessing'!
changeList
	^ changeList! !

!ChangeList methodsFor: 'accessing'!
file
	^file! !

!ChangeList methodsFor: 'accessing' stamp: 'di 6/15/97 15:13'!
setLostMethodPointer: sourcePointer
	lostMethodPointer _ sourcePointer! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ChangeList class
	instanceVariableNames: ''!

!ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:53'!
browseFile: fileName    "ChangeList browseFile: 'AutoDeclareFix.st'"
	"Opens a changeList on the file named fileName"
	| changesFile changeList |
	changesFile _ FileStream readOnlyFileNamed: fileName.
	Cursor read showWhile:
		[changeList _ self new
			scanFile: changesFile from: 0 to: changesFile size].
	changesFile close.
	self open: changeList name: fileName , ' log' multiSelect: true! !

!ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:53'!
browseRecent: charCount    "ChangeList browseRecent: 5000"
	"Opens a changeList on the end of the changes log file"
	| changesFile changeList end |
	changesFile _ (SourceFiles at: 2) readOnlyCopy.
	end _ changesFile size.
	Cursor read showWhile:
		[changeList _ self new
			scanFile: changesFile from: (0 max: end-charCount) to: end].
	changesFile close.
	self open: changeList name: 'Recent changes' multiSelect: true! !

!ChangeList class methodsFor: 'public access'!
browseRecentLog    "ChangeList browseRecentLog"
	"Prompt with a menu of how far back to go"
	| end changesFile banners positions pos chunk i |
	changesFile _ (SourceFiles at: 2) readOnlyCopy.
	banners _ OrderedCollection new.
	positions _ OrderedCollection new.
	end _ changesFile size.
	pos _ Smalltalk lastQuitLogPosition.
	[pos = 0 or: [banners size > 20]] whileFalse:
		[changesFile position: pos.
		chunk _ changesFile nextChunk.
		i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
		i > 0 ifTrue: [positions addLast: pos.
					banners addLast: (chunk copyFrom: 5 to: i-2).
					pos _ Number readFrom: (chunk copyFrom: i+13 to: chunk size)]
			ifFalse: [pos _ 0]].
	changesFile close.
	pos _ (SelectionMenu labelList: banners reversed selections: positions reversed)
				startUpWithCaption: 'Browse as far back as...'.
	pos == nil ifTrue: [^ self].
	self browseRecent: end-pos! !

!ChangeList class methodsFor: 'public access' stamp: 'tk 5/19/1998 14:24'!
browseStream: changesFile
	"Opens a changeList on a fileStream"
	| changeList |

	changesFile readOnly.
	Cursor read showWhile:
		[changeList _ self new
			scanFile: changesFile from: 0 to: changesFile size].
	changesFile close.
	self open: changeList name: changesFile localName , ' log' multiSelect: true! !

!ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:56'!
browseVersionsOf: method class: class meta: meta
		category: category selector: selector 
	| changeList |
	Cursor read showWhile:
		[changeList _ self new
			scanVersionsOf: method class: class meta: meta
			category: category selector: selector].
	changeList ifNotNil:
		[self open: changeList name: 'Recent versions of ' , selector multiSelect: false]! !

!ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:56'!
browseVersionsOf: method class: class meta: meta
		category: category selector: selector lostMethodPointer: sourcePointer
	| changeList |
	Cursor read showWhile:
		[changeList _ self new
			scanVersionsOf: method class: class meta: meta
			category: category selector: selector].
	changeList setLostMethodPointer: sourcePointer.
	self open: changeList name: 'Recent versions of ' , selector multiSelect: false! !

!ChangeList class methodsFor: 'public access'!
versionCountForSelector: aSelector class: aClass
	"Answer the number of versions known to the system for the given class and method, including the current version.  A result of greater than one means that there is at least one superseded version.  6/28/96 sw"
	
	| method |
	method _ aClass compiledMethodAt: aSelector.
	^ (self new
			scanVersionsOf: method class: aClass meta: aClass isMeta
			category: nil selector: aSelector) list size! !


!ChangeList class methodsFor: 'instance creation' stamp: 'di 5/17/1998 22:49'!
open: aChangeList name: aString multiSelect: multiSelect
	"Create a standard system view for the messageSet, whose label is aString.
	The listView may be either single or multiple selection type"
	| topView aBrowserCodeView aListView |

	World ifNotNil: [^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect].

	topView _ (StandardSystemView new) model: aChangeList.
	topView label: aString.
	topView minimumSize: 180 @ 120.
	topView borderWidth: 1.

	aListView _ (multiSelect ifTrue: [PluggableListViewOfMany]
							ifFalse: [PluggableListView])
		on: aChangeList list: #list
		selected: #listIndex changeSelected: #toggleListIndex:
		menu: #changeListMenu:
		keystroke: #messageListKey:from:.
	aListView window: (0 @ 0 extent: 180 @ 100).
	topView addSubView: aListView.

	aBrowserCodeView _ PluggableTextView on: aChangeList 
			text: #contents accept: #contents:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	aBrowserCodeView controller: ReadOnlyTextController new.
	aBrowserCodeView window: (0 @ 0 extent: 180 @ 300).
	topView addSubView: aBrowserCodeView below: aListView.
	topView controller open! !

!ChangeList class methodsFor: 'instance creation' stamp: 'di 5/16/1998 22:15'!
openAsMorph: aChangeList name: labelString multiSelect: multiSelect
	"Open a morphic view for the messageSet, whose label is labelString.
	The listView may be either single or multiple selection type"
	| window listView textMorph |
	window _ (SystemWindow labelled: labelString) model: aChangeList.

	window addMorph: (listView _ PluggableListMorph on: aChangeList list: #list
		selected: #listIndex changeSelected: #toggleListIndex:
		menu: #changeListMenu: keystroke: #messageListKey:from:)
		frame: (0@0 corner: 1@0.3).
"
	multiSelect ifTrue: [listView controller: PluggableListControllerOfMany new].
"
	window addMorph: (textMorph _ PluggableTextMorph on: aChangeList 
			text: #contents accept: #contents:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
		frame: (0@0.3 corner: 1@1).
"
	textMorph controller: ReadOnlyTextController new.
"
	^ window openInWorld! !
Object subclass: #ChangeRecord
	instanceVariableNames: 'file position type class category meta stamp '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Changes'!
!ChangeRecord commentStamp: 'di 5/22/1998 16:32' prior: 0!
ChangeRecord comment:
'A ChangeRecord represents a change recorded on a file in fileOut format.
It includes a type (more needs to be done here), and additional information
for certain types such as method defs which need class and category.'!


!ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:46'!
fileIn
	| methodClass |
	Cursor read showWhile:
		[(methodClass _ self methodClass) notNil ifTrue:
			[methodClass compile: self text classified: category withStamp: stamp notifying: nil].
		(type == #doIt) ifTrue:
			[Compiler evaluate: self string].
		(type == #classComment) ifTrue:
			[(Smalltalk at: class asSymbol) comment: self text]]! !

!ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:09'!
fileOutOn: f
	type == #method
		ifTrue:
			[f nextPut: $!!.
			f nextChunkPut: class asString
					, (meta ifTrue: [' class methodsFor: ']
							ifFalse: [' methodsFor: '])
					, category asString printString.
			f cr].

	type == #preamble ifTrue: [f nextPut: $!!].

	type == #classComment
		ifTrue:
			[f nextPut: $!!.
			f nextChunkPut: class asString, ' commentStamp: ', stamp storeString.
			f cr].

	f nextChunkPut: self string.
	type == #method ifTrue: [f nextChunkPut: ' '].
	f cr! !

!ChangeRecord methodsFor: 'access'!
methodClass 
	| methodClass |
	type == #method ifFalse: [^ nil].
	(Smalltalk includesKey: class asSymbol) ifFalse: [^ nil].
	methodClass _ Smalltalk at: class asSymbol.
	meta ifTrue: [^ methodClass class]
		ifFalse: [^ methodClass]! !

!ChangeRecord methodsFor: 'access'!
methodSelector
	type == #method ifFalse: [^ nil].
	^ Parser new parseSelector: self string! !

!ChangeRecord methodsFor: 'access' stamp: '6/6/97 08:56 dhhi'!
stamp
	^ stamp! !

!ChangeRecord methodsFor: 'access' stamp: 'di 1/13/98 16:57'!
string 
	| string |
	file openReadOnly.
	file position: position.
	string _ file nextChunk.
	file close.
	^ string! !

!ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:35'!
text
	| text |
	file openReadOnly.
	file position: position.
	text _ file nextChunkText.
	file close.
	^ text! !

!ChangeRecord methodsFor: 'access'!
type
	^ type! !


!ChangeRecord methodsFor: 'initialization'!
file: f position: p type: t
	file _ f.
	position _ p.
	type _ t! !

!ChangeRecord methodsFor: 'initialization' stamp: '6/6/97 08:48 dhhi'!
file: f position: p type: t class: c category: cat meta: m stamp: s
	self file: f position: p type: t.
	class _ c.
	category _ cat.
	meta _ m.
	stamp _ s! !
Object subclass: #ChangeSet
	instanceVariableNames: 'classChanges methodChanges classRemoves methodRemoves name preamble postscript '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Changes'!
!ChangeSet commentStamp: 'di 5/22/1998 16:32' prior: 0!
ChangeSet comment:
'My instances keep track of the changes made to a system, so the user can make an incremental fileOut. The order in which changes are made is not remembered.

classChanges:  Dictionary {class name -> Set {eg, #change, #rename, etc}}.
methodChanges:  Dictionary {class name -> IdentityDictionary {selector -> {eg, #change, #remove, etc}}.
classRemoves:  Set {class name (original)}.
methodRemoves:  Dictionary {(Array with: class name with: selector) -> (Array with: source pointer with: category)}.
name: a String used to name the changeSet, and thus any associated project or fileOut.
preamble and postscript:  two strings that serve as prefix (useful for documentation) and suffix (useful for doits) to the fileout of the changeSet.'!


!ChangeSet methodsFor: 'initialize-release' stamp: 'sw 11/26/96'!
clear 
	"Reset the receiver to be empty.  "

	classChanges _ Dictionary new.
	methodChanges _ Dictionary new.
	classRemoves _ Set new.
	preamble _ nil.
	postscript _ nil! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'tk 5/4/1998 16:41'!
editPostscript
	"edit the receiver's postscript, in a separate window.  "

	self assurePostscriptExists.
	postscript openLabel: 'Postscript for ChangeSet named ', name! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 5/21/1998 20:50'!
initialize 
	"Reset the receiver to be empty."

	self wither.  "Avoid duplicate entries in AllChangeSets if initialize gets called twice"
	name _ ChangeSet defaultName! !

!ChangeSet methodsFor: 'initialize-release'!
isMoribund
	"Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter.  2/7/96 sw"

	^ name == nil ! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 5/21/1998 20:50'!
wither
	"The receiver is to be clobbered.  Clear it out.  2/7/96 sw"

	classChanges _ Dictionary new.
	methodChanges _ Dictionary new.
	classRemoves _ Set new.
	methodRemoves _ Dictionary new.
	name _ nil! !


!ChangeSet methodsFor: 'testing' stamp: 'jm 5/22/1998 11:33'!
belongsToAProject

	Project allInstancesDo: [:proj |
		proj projectChangeSet == self ifTrue: [^ true]].
	^ false
! !

!ChangeSet methodsFor: 'testing' stamp: 'tk 5/7/1998 12:57'!
classChangeAt: className
	"Return what we know about class changes to this class."
	| this |

	this _ classChanges at: className ifAbsent: [Set new].
	(classRemoves includes: className) ifTrue: [this add: #remove].
	^ this! !

!ChangeSet methodsFor: 'testing'!
classRemoves
	^ classRemoves! !

!ChangeSet methodsFor: 'testing'!
isEmpty
	"Answer whether the receiver contains any elements."

	^(methodChanges isEmpty and: [classChanges isEmpty]) and: [classRemoves isEmpty]! !

!ChangeSet methodsFor: 'testing'!
methodChangesAtClass: className
	"Return what we know about method changes to this class."
	^ methodChanges at: className ifAbsent: [Dictionary new].! !

!ChangeSet methodsFor: 'testing'!
name
	"The name of this changeSet.
	 2/7/96 sw: If name is nil, we've got garbage.  Help to identify."

	^ name == nil
		ifTrue:
			['<no name -- garbage?>']
		ifFalse:
			[name]! !

!ChangeSet methodsFor: 'testing' stamp: 'sw 10/1/97 17:59'!
okayToRemove
	| aName |
	aName _ self name.
	self == Smalltalk changes ifTrue:
		[self inform: 'Cannot remove "', aName, '"
because it is the 
current change set.'.
		^ false].

	self belongsToAProject ifTrue:
		[self inform: 'Cannot remove "', aName, '" 
because it belongs to a 
project.'.
			^ false].

	^ true
! !


!ChangeSet methodsFor: 'converting'!
asSortedCollection
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is the default less than or equal ordering."
	| result |
	result _ SortedCollection new.
	classChanges associationsDo: 
		[:clAssoc | 
		clAs