'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: [t